gcc/f/com.c

   1 /* com.c -- Implementation File (module.c template V1.0)
   2    Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000
   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    int yes;
  58    yes = suspend_momentary ();
  59    if (is_nested) push_f_function_context ();
  60    start_function (get_identifier ("function_name"), function_type,
  61                    is_nested, is_public);
  62    // for each arg, build PARM_DECL and call push_parm_decl (decl) with it;
  63    store_parm_decls (is_main_program);
  64    ffecom_start_compstmt ();
  65    // for stmts and decls inside function, do appropriate things;
  66    ffecom_end_compstmt ();
  67    finish_function (is_nested);
  68    if (is_nested) pop_f_function_context ();
  69    if (is_nested) resume_momentary (yes);
  70
  71    Everything Else:
  72    int yes;
  73    tree d;
  74    tree init;
  75    yes = suspend_momentary ();
  76    // fill in external, public, static, &c for decl, and
  77    // set DECL_INITIAL to error_mark_node if going to initialize
  78    // set is_top_level TRUE only if not at top level and decl
  79    // must go in top level (i.e. not within current function decl context)
  80    d = start_decl (decl, is_top_level);
  81    init = ...;  // if have initializer
  82    finish_decl (d, init, is_top_level);
  83    resume_momentary (yes);
  84
  85 */
  86
  87 /* Include files. */
  88
  89 #include "proj.h"
  90 #if FFECOM_targetCURRENT == FFECOM_targetGCC
  91 #include "flags.h"
  92 #include "rtl.h"
  93 #include "toplev.h"
  94 #include "tree.h"
  95 #include "output.h"  /* Must follow tree.h so TREE_CODE is defined! */
  96 #include "convert.h"
  97 #include "ggc.h"
  98 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
  99
 100 #define FFECOM_GCC_INCLUDE 1    /* Enable -I. */
 101
 102 /* BEGIN stuff from gcc/cccp.c.  */
 103
 104 /* The following symbols should be autoconfigured:
 105         HAVE_FCNTL_H
 106         HAVE_STDLIB_H
 107         HAVE_SYS_TIME_H
 108         HAVE_UNISTD_H
 109         STDC_HEADERS
 110         TIME_WITH_SYS_TIME
 111    In the mean time, we'll get by with approximations based
 112    on existing GCC configuration symbols.  */
 113
 114 #ifdef POSIX
 115 # ifndef HAVE_STDLIB_H
 116 # define HAVE_STDLIB_H 1
 117 # endif
 118 # ifndef HAVE_UNISTD_H
 119 # define HAVE_UNISTD_H 1
 120 # endif
 121 # ifndef STDC_HEADERS
 122 # define STDC_HEADERS 1
 123 # endif
 124 #endif /* defined (POSIX) */
 125
 126 #if defined (POSIX) || (defined (USG) && !defined (VMS))
 127 # ifndef HAVE_FCNTL_H
 128 # define HAVE_FCNTL_H 1
 129 # endif
 130 #endif
 131
 132 #ifndef RLIMIT_STACK
 133 # include <time.h>
 134 #else
 135 # if TIME_WITH_SYS_TIME
 136 #  include <sys/time.h>
 137 #  include <time.h>
 138 # else
 139 #  if HAVE_SYS_TIME_H
 140 #   include <sys/time.h>
 141 #  else
 142 #   include <time.h>
 143 #  endif
 144 # endif
 145 # include <sys/resource.h>
 146 #endif
 147
 148 #if HAVE_FCNTL_H
 149 # include <fcntl.h>
 150 #endif
 151
 152 /* This defines "errno" properly for VMS, and gives us EACCES. */
 153 #include <errno.h>
 154
 155 #if HAVE_STDLIB_H
 156 # include <stdlib.h>
 157 #else
 158 char *getenv ();
 159 #endif
 160
 161 #if HAVE_UNISTD_H
 162 # include <unistd.h>
 163 #endif
 164
 165 /* VMS-specific definitions */
 166 #ifdef VMS
 167 #include <descrip.h>
 168 #define O_RDONLY        0       /* Open arg for Read/Only  */
 169 #define O_WRONLY        1       /* Open arg for Write/Only */
 170 #define read(fd,buf,size)       VMS_read (fd,buf,size)
 171 #define write(fd,buf,size)      VMS_write (fd,buf,size)
 172 #define open(fname,mode,prot)   VMS_open (fname,mode,prot)
 173 #define fopen(fname,mode)       VMS_fopen (fname,mode)
 174 #define freopen(fname,mode,ofile) VMS_freopen (fname,mode,ofile)
 175 #define strncat(dst,src,cnt) VMS_strncat (dst,src,cnt)
 176 #define fstat(fd,stbuf)         VMS_fstat (fd,stbuf)
 177 static int VMS_fstat (), VMS_stat ();
 178 static char * VMS_strncat ();
 179 static int VMS_read ();
 180 static int VMS_write ();
 181 static int VMS_open ();
 182 static FILE * VMS_fopen ();
 183 static FILE * VMS_freopen ();
 184 static void hack_vms_include_specification ();
 185 typedef struct { unsigned :16, :16, :16; } vms_ino_t;
 186 #define ino_t vms_ino_t
 187 #define INCLUDE_LEN_FUDGE 10    /* leave room for VMS syntax conversion */
 188 #ifdef __GNUC__
 189 #define BSTRING                 /* VMS/GCC supplies the bstring routines */
 190 #endif /* __GNUC__ */
 191 #endif /* VMS */
 192
 193 #ifndef O_RDONLY
 194 #define O_RDONLY 0
 195 #endif
 196
 197 /* END stuff from gcc/cccp.c.  */
 198
 199 #define FFECOM_DETERMINE_TYPES 1 /* for com.h */
 200 #include "com.h"
 201 #include "bad.h"
 202 #include "bld.h"
 203 #include "equiv.h"
 204 #include "expr.h"
 205 #include "implic.h"
 206 #include "info.h"
 207 #include "malloc.h"
 208 #include "src.h"
 209 #include "st.h"
 210 #include "storag.h"
 211 #include "symbol.h"
 212 #include "target.h"
 213 #include "top.h"
 214 #include "type.h"
 215
 216 /* Externals defined here.  */
 217
 218 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 219
 220 /* ~~gcc/tree.h *should* declare this, because toplev.c and dwarfout.c
 221    reference it.  */
 222
 223 const char * const language_string = "GNU F77";
 224
 225 /* Stream for reading from the input file.  */
 226 FILE *finput;
 227
 228 /* These definitions parallel those in c-decl.c so that code from that
 229    module can be used pretty much as is.  Much of these defs aren't
 230    otherwise used, i.e. by g77 code per se, except some of them are used
 231    to build some of them that are.  The ones that are global (i.e. not
 232    "static") are those that ste.c and such might use (directly
 233    or by using com macros that reference them in their definitions).  */
 234
 235 tree string_type_node;
 236
 237 /* The rest of these are inventions for g77, though there might be
 238    similar things in the C front end.  As they are found, these
 239    inventions should be renamed to be canonical.  Note that only
 240    the ones currently required to be global are so.  */
 241
 242 static tree ffecom_tree_fun_type_void;
 243
 244 tree ffecom_integer_type_node;  /* Abbrev for _tree_type[blah][blah]. */
 245 tree ffecom_integer_zero_node;  /* Like *_*_* with g77's integer type. */
 246 tree ffecom_integer_one_node;   /* " */
 247 tree ffecom_tree_type[FFEINFO_basictype][FFEINFO_kindtype];
 248
 249 /* _fun_type things are the f2c-specific versions.  For -fno-f2c,
 250    just use build_function_type and build_pointer_type on the
 251    appropriate _tree_type array element.  */
 252
 253 static tree ffecom_tree_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
 254 static tree ffecom_tree_ptr_to_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
 255 static tree ffecom_tree_subr_type;
 256 static tree ffecom_tree_ptr_to_subr_type;
 257 static tree ffecom_tree_blockdata_type;
 258
 259 static tree ffecom_tree_xargc_;
 260
 261 ffecomSymbol ffecom_symbol_null_
 262 =
 263 {
 264   NULL_TREE,
 265   NULL_TREE,
 266   NULL_TREE,
 267   NULL_TREE,
 268   false
 269 };
 270 ffeinfoKindtype ffecom_pointer_kind_ = FFEINFO_basictypeNONE;
 271 ffeinfoKindtype ffecom_label_kind_ = FFEINFO_basictypeNONE;
 272
 273 int ffecom_f2c_typecode_[FFEINFO_basictype][FFEINFO_kindtype];
 274 tree ffecom_f2c_integer_type_node;
 275 tree ffecom_f2c_ptr_to_integer_type_node;
 276 tree ffecom_f2c_address_type_node;
 277 tree ffecom_f2c_real_type_node;
 278 tree ffecom_f2c_ptr_to_real_type_node;
 279 tree ffecom_f2c_doublereal_type_node;
 280 tree ffecom_f2c_complex_type_node;
 281 tree ffecom_f2c_doublecomplex_type_node;
 282 tree ffecom_f2c_longint_type_node;
 283 tree ffecom_f2c_logical_type_node;
 284 tree ffecom_f2c_flag_type_node;
 285 tree ffecom_f2c_ftnlen_type_node;
 286 tree ffecom_f2c_ftnlen_zero_node;
 287 tree ffecom_f2c_ftnlen_one_node;
 288 tree ffecom_f2c_ftnlen_two_node;
 289 tree ffecom_f2c_ptr_to_ftnlen_type_node;
 290 tree ffecom_f2c_ftnint_type_node;
 291 tree ffecom_f2c_ptr_to_ftnint_type_node;
 292 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 293
 294 /* Simple definitions and enumerations. */
 295
 296 #ifndef FFECOM_sizeMAXSTACKITEM
 297 #define FFECOM_sizeMAXSTACKITEM 32*1024 /* Keep user-declared things
 298                                            larger than this # bytes
 299                                            off stack if possible. */
 300 #endif
 301
 302 /* For systems that have large enough stacks, they should define
 303    this to 0, and here, for ease of use later on, we just undefine
 304    it if it is 0.  */
 305
 306 #if FFECOM_sizeMAXSTACKITEM == 0
 307 #undef FFECOM_sizeMAXSTACKITEM
 308 #endif
 309
 310 typedef enum
 311   {
 312     FFECOM_rttypeVOID_,
 313     FFECOM_rttypeVOIDSTAR_,     /* C's `void *' type. */
 314     FFECOM_rttypeFTNINT_,       /* f2c's `ftnint' type. */
 315     FFECOM_rttypeINTEGER_,      /* f2c's `integer' type. */
 316     FFECOM_rttypeLONGINT_,      /* f2c's `longint' type. */
 317     FFECOM_rttypeLOGICAL_,      /* f2c's `logical' type. */
 318     FFECOM_rttypeREAL_F2C_,     /* f2c's `real' returned as `double'. */
 319     FFECOM_rttypeREAL_GNU_,     /* `real' returned as such. */
 320     FFECOM_rttypeCOMPLEX_F2C_,  /* f2c's `complex' returned via 1st arg. */
 321     FFECOM_rttypeCOMPLEX_GNU_,  /* f2c's `complex' returned directly. */
 322     FFECOM_rttypeDOUBLE_,       /* C's `double' type. */
 323     FFECOM_rttypeDOUBLEREAL_,   /* f2c's `doublereal' type. */
 324     FFECOM_rttypeDBLCMPLX_F2C_, /* f2c's `doublecomplex' returned via 1st arg. */
 325     FFECOM_rttypeDBLCMPLX_GNU_, /* f2c's `doublecomplex' returned directly. */
 326     FFECOM_rttypeCHARACTER_,    /* f2c `char *'/`ftnlen' pair. */
 327     FFECOM_rttype_
 328   } ffecomRttype_;
 329
 330 /* Internal typedefs. */
 331
 332 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 333 typedef struct _ffecom_concat_list_ ffecomConcatList_;
 334 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 335
 336 /* Private include files. */
 337
 338
 339 /* Internal structure definitions. */
 340
 341 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 342 struct _ffecom_concat_list_
 343   {
 344     ffebld *exprs;
 345     int count;
 346     int max;
 347     ffetargetCharacterSize minlen;
 348     ffetargetCharacterSize maxlen;
 349   };
 350 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 351
 352 /* Static functions (internal). */
 353
 354 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 355 static tree ffecom_arglist_expr_ (const char *argstring, ffebld args);
 356 static tree ffecom_widest_expr_type_ (ffebld list);
 357 static bool ffecom_overlap_ (tree dest_decl, tree dest_offset,
 358                              tree dest_size, tree source_tree,
 359                              ffebld source, bool scalar_arg);
 360 static bool ffecom_args_overlapping_ (tree dest_tree, ffebld dest,
 361                                       tree args, tree callee_commons,
 362                                       bool scalar_args);
 363 static tree ffecom_build_f2c_string_ (int i, const char *s);
 364 static tree ffecom_call_ (tree fn, ffeinfoKindtype kt,
 365                           bool is_f2c_complex, tree type,
 366                           tree args, tree dest_tree,
 367                           ffebld dest, bool *dest_used,
 368                           tree callee_commons, bool scalar_args, tree hook);
 369 static tree ffecom_call_binop_ (tree fn, ffeinfoKindtype kt,
 370                                 bool is_f2c_complex, tree type,
 371                                 ffebld left, ffebld right,
 372                                 tree dest_tree, ffebld dest,
 373                                 bool *dest_used, tree callee_commons,
 374                                 bool scalar_args, tree hook);
 375 static void ffecom_char_args_x_ (tree *xitem, tree *length,
 376                                  ffebld expr, bool with_null);
 377 static tree ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy);
 378 static tree ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s);
 379 static ffecomConcatList_
 380   ffecom_concat_list_gather_ (ffecomConcatList_ catlist,
 381                               ffebld expr,
 382                               ffetargetCharacterSize max);
 383 static void ffecom_concat_list_kill_ (ffecomConcatList_ catlist);
 384 static ffecomConcatList_ ffecom_concat_list_new_ (ffebld expr,
 385                                                 ffetargetCharacterSize max);
 386 static void ffecom_debug_kludge_ (tree aggr, const char *aggr_type,
 387                                   ffesymbol member, tree member_type,
 388                                   ffetargetOffset offset);
 389 static void ffecom_do_entry_ (ffesymbol fn, int entrynum);
 390 static tree ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
 391                           bool *dest_used, bool assignp, bool widenp);
 392 static tree ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
 393                                     ffebld dest, bool *dest_used);
 394 static tree ffecom_expr_power_integer_ (ffebld expr);
 395 static void ffecom_expr_transform_ (ffebld expr);
 396 static void ffecom_f2c_make_type_ (tree *type, int tcode, const char *name);
 397 static void ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
 398                                       int code);
 399 static ffeglobal ffecom_finish_global_ (ffeglobal global);
 400 static ffesymbol ffecom_finish_symbol_transform_ (ffesymbol s);
 401 static tree ffecom_get_appended_identifier_ (char us, const char *text);
 402 static tree ffecom_get_external_identifier_ (ffesymbol s);
 403 static tree ffecom_get_identifier_ (const char *text);
 404 static tree ffecom_gen_sfuncdef_ (ffesymbol s,
 405                                   ffeinfoBasictype bt,
 406                                   ffeinfoKindtype kt);
 407 static const char *ffecom_gfrt_args_ (ffecomGfrt ix);
 408 static tree ffecom_gfrt_tree_ (ffecomGfrt ix);
 409 static tree ffecom_init_zero_ (tree decl);
 410 static tree ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
 411                                      tree *maybe_tree);
 412 static tree ffecom_intrinsic_len_ (ffebld expr);
 413 static void ffecom_let_char_ (tree dest_tree,
 414                               tree dest_length,
 415                               ffetargetCharacterSize dest_size,
 416                               ffebld source);
 417 static void ffecom_make_gfrt_ (ffecomGfrt ix);
 418 static void ffecom_member_phase1_ (ffestorag mst, ffestorag st);
 419 static void ffecom_member_phase2_ (ffestorag mst, ffestorag st);
 420 static void ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size,
 421                                       ffebld source);
 422 static void ffecom_push_dummy_decls_ (ffebld dumlist,
 423                                       bool stmtfunc);
 424 static void ffecom_start_progunit_ (void);
 425 static ffesymbol ffecom_sym_transform_ (ffesymbol s);
 426 static ffesymbol ffecom_sym_transform_assign_ (ffesymbol s);
 427 static void ffecom_transform_common_ (ffesymbol s);
 428 static void ffecom_transform_equiv_ (ffestorag st);
 429 static tree ffecom_transform_namelist_ (ffesymbol s);
 430 static void ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
 431                                        tree t);
 432 static void ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
 433                                        tree *size, tree tree);
 434 static tree ffecom_tree_divide_ (tree tree_type, tree left, tree right,
 435                                  tree dest_tree, ffebld dest,
 436                                  bool *dest_used, tree hook);
 437 static tree ffecom_type_localvar_ (ffesymbol s,
 438                                    ffeinfoBasictype bt,
 439                                    ffeinfoKindtype kt);
 440 static tree ffecom_type_namelist_ (void);
 441 static tree ffecom_type_vardesc_ (void);
 442 static tree ffecom_vardesc_ (ffebld expr);
 443 static tree ffecom_vardesc_array_ (ffesymbol s);
 444 static tree ffecom_vardesc_dims_ (ffesymbol s);
 445 static tree ffecom_convert_narrow_ (tree type, tree expr);
 446 static tree ffecom_convert_widen_ (tree type, tree expr);
 447 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 448
 449 /* These are static functions that parallel those found in the C front
 450    end and thus have the same names.  */
 451
 452 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 453 static tree bison_rule_compstmt_ (void);
 454 static void bison_rule_pushlevel_ (void);
 455 static void delete_block (tree block);
 456 static int duplicate_decls (tree newdecl, tree olddecl);
 457 static void finish_decl (tree decl, tree init, bool is_top_level);
 458 static void finish_function (int nested);
 459 static const char *lang_printable_name (tree decl, int v);
 460 static tree lookup_name_current_level (tree name);
 461 static struct binding_level *make_binding_level (void);
 462 static void pop_f_function_context (void);
 463 static void push_f_function_context (void);
 464 static void push_parm_decl (tree parm);
 465 static tree pushdecl_top_level (tree decl);
 466 static int kept_level_p (void);
 467 static tree storedecls (tree decls);
 468 static void store_parm_decls (int is_main_program);
 469 static tree start_decl (tree decl, bool is_top_level);
 470 static void start_function (tree name, tree type, int nested, int public);
 471 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 472 #if FFECOM_GCC_INCLUDE
 473 static void ffecom_file_ (const char *name);
 474 static void ffecom_initialize_char_syntax_ (void);
 475 static void ffecom_close_include_ (FILE *f);
 476 static int ffecom_decode_include_option_ (char *spec);
 477 static FILE *ffecom_open_include_ (char *name, ffewhereLine l,
 478                                    ffewhereColumn c);
 479 #endif  /* FFECOM_GCC_INCLUDE */
 480
 481 /* Static objects accessed by functions in this module. */
 482
 483 static ffesymbol ffecom_primary_entry_ = NULL;
 484 static ffesymbol ffecom_nested_entry_ = NULL;
 485 static ffeinfoKind ffecom_primary_entry_kind_;
 486 static bool ffecom_primary_entry_is_proc_;
 487 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 488 static tree ffecom_outer_function_decl_;
 489 static tree ffecom_previous_function_decl_;
 490 static tree ffecom_which_entrypoint_decl_;
 491 static tree ffecom_float_zero_ = NULL_TREE;
 492 static tree ffecom_float_half_ = NULL_TREE;
 493 static tree ffecom_double_zero_ = NULL_TREE;
 494 static tree ffecom_double_half_ = NULL_TREE;
 495 static tree ffecom_func_result_;/* For functions. */
 496 static tree ffecom_func_length_;/* For CHARACTER fns. */
 497 static ffebld ffecom_list_blockdata_;
 498 static ffebld ffecom_list_common_;
 499 static ffebld ffecom_master_arglist_;
 500 static ffeinfoBasictype ffecom_master_bt_;
 501 static ffeinfoKindtype ffecom_master_kt_;
 502 static ffetargetCharacterSize ffecom_master_size_;
 503 static int ffecom_num_fns_ = 0;
 504 static int ffecom_num_entrypoints_ = 0;
 505 static bool ffecom_is_altreturning_ = FALSE;
 506 static tree ffecom_multi_type_node_;
 507 static tree ffecom_multi_retval_;
 508 static tree
 509   ffecom_multi_fields_[FFEINFO_basictype][FFEINFO_kindtype];
 510 static bool ffecom_member_namelisted_;  /* _member_phase1_ namelisted? */
 511 static bool ffecom_doing_entry_ = FALSE;
 512 static bool ffecom_transform_only_dummies_ = FALSE;
 513 static int ffecom_typesize_pointer_;
 514 static int ffecom_typesize_integer1_;
 515
 516 /* Holds pointer-to-function expressions.  */
 517
 518 static tree ffecom_gfrt_[FFECOM_gfrt]
 519 =
 520 {
 521 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) NULL_TREE,
 522 #include "com-rt.def"
 523 #undef DEFGFRT
 524 };
 525
 526 /* Holds the external names of the functions.  */
 527
 528 static const char *ffecom_gfrt_name_[FFECOM_gfrt]
 529 =
 530 {
 531 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) NAME,
 532 #include "com-rt.def"
 533 #undef DEFGFRT
 534 };
 535
 536 /* Whether the function returns.  */
 537
 538 static bool ffecom_gfrt_volatile_[FFECOM_gfrt]
 539 =
 540 {
 541 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) VOLATILE,
 542 #include "com-rt.def"
 543 #undef DEFGFRT
 544 };
 545
 546 /* Whether the function returns type complex.  */
 547
 548 static bool ffecom_gfrt_complex_[FFECOM_gfrt]
 549 =
 550 {
 551 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) COMPLEX,
 552 #include "com-rt.def"
 553 #undef DEFGFRT
 554 };
 555
 556 /* Type code for the function return value.  */
 557
 558 static ffecomRttype_ ffecom_gfrt_type_[FFECOM_gfrt]
 559 =
 560 {
 561 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) TYPE,
 562 #include "com-rt.def"
 563 #undef DEFGFRT
 564 };
 565
 566 /* String of codes for the function's arguments.  */
 567
 568 static const char *ffecom_gfrt_argstring_[FFECOM_gfrt]
 569 =
 570 {
 571 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) ARGS,
 572 #include "com-rt.def"
 573 #undef DEFGFRT
 574 };
 575 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 576
 577 /* Internal macros. */
 578
 579 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 580
 581 /* We let tm.h override the types used here, to handle trivial differences
 582    such as the choice of unsigned int or long unsigned int for size_t.
 583    When machines start needing nontrivial differences in the size type,
 584    it would be best to do something here to figure out automatically
 585    from other information what type to use.  */
 586
 587 #ifndef SIZE_TYPE
 588 #define SIZE_TYPE "long unsigned int"
 589 #endif
 590
 591 #define ffecom_concat_list_count_(catlist) ((catlist).count)
 592 #define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)])
 593 #define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen)
 594 #define ffecom_concat_list_minlen_(catlist) ((catlist).minlen)
 595
 596 #define ffecom_char_args_(i,l,e) ffecom_char_args_x_((i),(l),(e),FALSE)
 597 #define ffecom_char_args_with_null_(i,l,e) ffecom_char_args_x_((i),(l),(e),TRUE)
 598
 599 /* For each binding contour we allocate a binding_level structure
 600  * which records the names defined in that contour.
 601  * Contours include:
 602  *  0) the global one
 603  *  1) one for each function definition,
 604  *     where internal declarations of the parameters appear.
 605  *
 606  * The current meaning of a name can be found by searching the levels from
 607  * the current one out to the global one.
 608  */
 609
 610 /* Note that the information in the `names' component of the global contour
 611    is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers.  */
 612
 613 struct binding_level
 614   {
 615     /* A chain of _DECL nodes for all variables, constants, functions,
 616        and typedef types.  These are in the reverse of the order supplied.
 617      */
 618     tree names;
 619
 620     /* For each level (except not the global one),
 621        a chain of BLOCK nodes for all the levels
 622        that were entered and exited one level down.  */
 623     tree blocks;
 624
 625     /* The BLOCK node for this level, if one has been preallocated.
 626        If 0, the BLOCK is allocated (if needed) when the level is popped.  */
 627     tree this_block;
 628
 629     /* The binding level which this one is contained in (inherits from).  */
 630     struct binding_level *level_chain;
 631
 632     /* 0: no ffecom_prepare_* functions called at this level yet;
 633        1: ffecom_prepare* functions called, except not ffecom_prepare_end;
 634        2: ffecom_prepare_end called.  */
 635     int prep_state;
 636   };
 637
 638 #define NULL_BINDING_LEVEL (struct binding_level *) NULL
 639
 640 /* The binding level currently in effect.  */
 641
 642 static struct binding_level *current_binding_level;
 643
 644 /* A chain of binding_level structures awaiting reuse.  */
 645
 646 static struct binding_level *free_binding_level;
 647
 648 /* The outermost binding level, for names of file scope.
 649    This is created when the compiler is started and exists
 650    through the entire run.  */
 651
 652 static struct binding_level *global_binding_level;
 653
 654 /* Binding level structures are initialized by copying this one.  */
 655
 656 static struct binding_level clear_binding_level
 657 =
 658 {NULL, NULL, NULL, NULL_BINDING_LEVEL, 0};
 659
 660 /* Language-dependent contents of an identifier.  */
 661
 662 struct lang_identifier
 663   {
 664     struct tree_identifier ignore;
 665     tree global_value, local_value, label_value;
 666     bool invented;
 667   };
 668
 669 /* Macros for access to language-specific slots in an identifier.  */
 670 /* Each of these slots contains a DECL node or null.  */
 671
 672 /* This represents the value which the identifier has in the
 673    file-scope namespace.  */
 674 #define IDENTIFIER_GLOBAL_VALUE(NODE)   \
 675   (((struct lang_identifier *)(NODE))->global_value)
 676 /* This represents the value which the identifier has in the current
 677    scope.  */
 678 #define IDENTIFIER_LOCAL_VALUE(NODE)    \
 679   (((struct lang_identifier *)(NODE))->local_value)
 680 /* This represents the value which the identifier has as a label in
 681    the current label scope.  */
 682 #define IDENTIFIER_LABEL_VALUE(NODE)    \
 683   (((struct lang_identifier *)(NODE))->label_value)
 684 /* This is nonzero if the identifier was "made up" by g77 code.  */
 685 #define IDENTIFIER_INVENTED(NODE)       \
 686   (((struct lang_identifier *)(NODE))->invented)
 687
 688 /* In identifiers, C uses the following fields in a special way:
 689    TREE_PUBLIC        to record that there was a previous local extern decl.
 690    TREE_USED          to record that such a decl was used.
 691    TREE_ADDRESSABLE   to record that the address of such a decl was used.  */
 692
 693 /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
 694    that have names.  Here so we can clear out their names' definitions
 695    at the end of the function.  */
 696
 697 static tree named_labels;
 698
 699 /* A list of LABEL_DECLs from outer contexts that are currently shadowed.  */
 700
 701 static tree shadowed_labels;
 702
 703 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 704 \f
 705 /* Return the subscript expression, modified to do range-checking.
 706
 707    `array' is the array to be checked against.
 708    `element' is the subscript expression to check.
 709    `dim' is the dimension number (starting at 0).
 710    `total_dims' is the total number of dimensions (0 for CHARACTER substring).
 711 */
 712
 713 static tree
 714 ffecom_subscript_check_ (tree array, tree element, int dim, int total_dims,
 715                          const char *array_name)
 716 {
 717   tree low = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 718   tree high = TYPE_MAX_VALUE (TYPE_DOMAIN (array));
 719   tree cond;
 720   tree die;
 721   tree args;
 722
 723   if (element == error_mark_node)
 724     return element;
 725
 726   if (TREE_TYPE (low) != TREE_TYPE (element))
 727     {
 728       if (TYPE_PRECISION (TREE_TYPE (low))
 729           > TYPE_PRECISION (TREE_TYPE (element)))
 730         element = convert (TREE_TYPE (low), element);
 731       else
 732         {
 733           low = convert (TREE_TYPE (element), low);
 734           if (high)
 735             high = convert (TREE_TYPE (element), high);
 736         }
 737     }
 738
 739   element = ffecom_save_tree (element);
 740   cond = ffecom_2 (LE_EXPR, integer_type_node,
 741                    low,
 742                    element);
 743   if (high)
 744     {
 745       cond = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
 746                        cond,
 747                        ffecom_2 (LE_EXPR, integer_type_node,
 748                                  element,
 749                                  high));
 750     }
 751
 752   {
 753     int len;
 754     char *proc;
 755     char *var;
 756     tree arg3;
 757     tree arg2;
 758     tree arg1;
 759     tree arg4;
 760
 761     switch (total_dims)
 762       {
 763       case 0:
 764         var = xmalloc (strlen (array_name) + 20);
 765         sprintf (var, "%s[%s-substring]",
 766                  array_name,
 767                  dim ? "end" : "start");
 768         len = strlen (var) + 1;
 769         arg1 = build_string (len, var);
 770         free (var);
 771         break;
 772
 773       case 1:
 774         len = strlen (array_name) + 1;
 775         arg1 = build_string (len, array_name);
 776         break;
 777
 778       default:
 779         var = xmalloc (strlen (array_name) + 40);
 780         sprintf (var, "%s[subscript-%d-of-%d]",
 781                  array_name,
 782                  dim + 1, total_dims);
 783         len = strlen (var) + 1;
 784         arg1 = build_string (len, var);
 785         free (var);
 786         break;
 787       }
 788
 789     TREE_TYPE (arg1)
 790       = build_type_variant (build_array_type (char_type_node,
 791                                               build_range_type
 792                                               (integer_type_node,
 793                                                integer_one_node,
 794                                                build_int_2 (len, 0))),
 795                             1, 0);
 796     TREE_CONSTANT (arg1) = 1;
 797     TREE_STATIC (arg1) = 1;
 798     arg1 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg1)),
 799                      arg1);
 800
 801     /* s_rnge adds one to the element to print it, so bias against
 802        that -- want to print a faithful *subscript* value.  */
 803     arg2 = convert (ffecom_f2c_ftnint_type_node,
 804                     ffecom_2 (MINUS_EXPR,
 805                               TREE_TYPE (element),
 806                               element,
 807                               convert (TREE_TYPE (element),
 808                                        integer_one_node)));
 809
 810     proc = xmalloc ((len = strlen (input_filename)
 811                      + IDENTIFIER_LENGTH (DECL_NAME (current_function_decl))
 812                      + 2));
 813
 814     sprintf (&proc[0], "%s/%s",
 815              input_filename,
 816              IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
 817     arg3 = build_string (len, proc);
 818
 819     free (proc);
 820
 821     TREE_TYPE (arg3)
 822       = build_type_variant (build_array_type (char_type_node,
 823                                               build_range_type
 824                                               (integer_type_node,
 825                                                integer_one_node,
 826                                                build_int_2 (len, 0))),
 827                             1, 0);
 828     TREE_CONSTANT (arg3) = 1;
 829     TREE_STATIC (arg3) = 1;
 830     arg3 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg3)),
 831                      arg3);
 832
 833     arg4 = convert (ffecom_f2c_ftnint_type_node,
 834                     build_int_2 (lineno, 0));
 835
 836     arg1 = build_tree_list (NULL_TREE, arg1);
 837     arg2 = build_tree_list (NULL_TREE, arg2);
 838     arg3 = build_tree_list (NULL_TREE, arg3);
 839     arg4 = build_tree_list (NULL_TREE, arg4);
 840     TREE_CHAIN (arg3) = arg4;
 841     TREE_CHAIN (arg2) = arg3;
 842     TREE_CHAIN (arg1) = arg2;
 843
 844     args = arg1;
 845   }
 846   die = ffecom_call_gfrt (FFECOM_gfrtRANGE,
 847                           args, NULL_TREE);
 848   TREE_SIDE_EFFECTS (die) = 1;
 849
 850   element = ffecom_3 (COND_EXPR,
 851                       TREE_TYPE (element),
 852                       cond,
 853                       element,
 854                       die);
 855
 856   return element;
 857 }
 858
 859 /* Return the computed element of an array reference.
 860
 861    `item' is NULL_TREE, or the transformed pointer to the array.
 862    `expr' is the original opARRAYREF expression, which is transformed
 863      if `item' is NULL_TREE.
 864    `want_ptr' is non-zero if a pointer to the element, instead of
 865      the element itself, is to be returned.  */
 866
 867 static tree
 868 ffecom_arrayref_ (tree item, ffebld expr, int want_ptr)
 869 {
 870   ffebld dims[FFECOM_dimensionsMAX];
 871   int i;
 872   int total_dims;
 873   int flatten = ffe_is_flatten_arrays ();
 874   int need_ptr;
 875   tree array;
 876   tree element;
 877   tree tree_type;
 878   tree tree_type_x;
 879   const char *array_name;
 880   ffetype type;
 881   ffebld list;
 882
 883   if (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER)
 884     array_name = ffesymbol_text (ffebld_symter (ffebld_left (expr)));
 885   else
 886     array_name = "[expr?]";
 887
 888   /* Build up ARRAY_REFs in reverse order (since we're column major
 889      here in Fortran land). */
 890
 891   for (i = 0, list = ffebld_right (expr);
 892        list != NULL;
 893        ++i, list = ffebld_trail (list))
 894     {
 895       dims[i] = ffebld_head (list);
 896       type = ffeinfo_type (ffebld_basictype (dims[i]),
 897                            ffebld_kindtype (dims[i]));
 898       if (! flatten
 899           && ffecom_typesize_pointer_ > ffecom_typesize_integer1_
 900           && ffetype_size (type) > ffecom_typesize_integer1_)
 901         /* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit
 902            pointers and 32-bit integers.  Do the full 64-bit pointer
 903            arithmetic, for codes using arrays for nonstandard heap-like
 904            work.  */
 905         flatten = 1;
 906     }
 907
 908   total_dims = i;
 909
 910   need_ptr = want_ptr || flatten;
 911
 912   if (! item)
 913     {
 914       if (need_ptr)
 915         item = ffecom_ptr_to_expr (ffebld_left (expr));
 916       else
 917         item = ffecom_expr (ffebld_left (expr));
 918
 919       if (item == error_mark_node)
 920         return item;
 921
 922       if (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING
 923           && ! mark_addressable (item))
 924         return error_mark_node;
 925     }
 926
 927   if (item == error_mark_node)
 928     return item;
 929
 930   if (need_ptr)
 931     {
 932       tree min;
 933
 934       for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
 935            i >= 0;
 936            --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
 937         {
 938           min = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 939           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 940           if (flag_bounds_check)
 941             element = ffecom_subscript_check_ (array, element, i, total_dims,
 942                                                array_name);
 943           if (element == error_mark_node)
 944             return element;
 945
 946           /* Widen integral arithmetic as desired while preserving
 947              signedness.  */
 948           tree_type = TREE_TYPE (element);
 949           tree_type_x = tree_type;
 950           if (tree_type
 951               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
 952               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
 953             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
 954
 955           if (TREE_TYPE (min) != tree_type_x)
 956             min = convert (tree_type_x, min);
 957           if (TREE_TYPE (element) != tree_type_x)
 958             element = convert (tree_type_x, element);
 959
 960           item = ffecom_2 (PLUS_EXPR,
 961                            build_pointer_type (TREE_TYPE (array)),
 962                            item,
 963                            size_binop (MULT_EXPR,
 964                                        size_in_bytes (TREE_TYPE (array)),
 965                                        convert (sizetype,
 966                                                 fold (build (MINUS_EXPR,
 967                                                              tree_type_x,
 968                                                              element, min)))));
 969         }
 970       if (! want_ptr)
 971         {
 972           item = ffecom_1 (INDIRECT_REF,
 973                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
 974                            item);
 975         }
 976     }
 977   else
 978     {
 979       for (--i;
 980            i >= 0;
 981            --i)
 982         {
 983           array = TYPE_MAIN_VARIANT (TREE_TYPE (item));
 984
 985           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 986           if (flag_bounds_check)
 987             element = ffecom_subscript_check_ (array, element, i, total_dims,
 988                                                array_name);
 989           if (element == error_mark_node)
 990             return element;
 991
 992           /* Widen integral arithmetic as desired while preserving
 993              signedness.  */
 994           tree_type = TREE_TYPE (element);
 995           tree_type_x = tree_type;
 996           if (tree_type
 997               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
 998               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
 999             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
1000
1001           element = convert (tree_type_x, element);
1002
1003           item = ffecom_2 (ARRAY_REF,
1004                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
1005                            item,
1006                            element);
1007         }
1008     }
1009
1010   return item;
1011 }
1012
1013 /* This is like gcc's stabilize_reference -- in fact, most of the code
1014    comes from that -- but it handles the situation where the reference
1015    is going to have its subparts picked at, and it shouldn't change
1016    (or trigger extra invocations of functions in the subtrees) due to
1017    this.  save_expr is a bit overzealous, because we don't need the
1018    entire thing calculated and saved like a temp.  So, for DECLs, no
1019    change is needed, because these are stable aggregates, and ARRAY_REF
1020    and such might well be stable too, but for things like calculations,
1021    we do need to calculate a snapshot of a value before picking at it.  */
1022
1023 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1024 static tree
1025 ffecom_stabilize_aggregate_ (tree ref)
1026 {
1027   tree result;
1028   enum tree_code code = TREE_CODE (ref);
1029
1030   switch (code)
1031     {
1032     case VAR_DECL:
1033     case PARM_DECL:
1034     case RESULT_DECL:
1035       /* No action is needed in this case.  */
1036       return ref;
1037
1038     case NOP_EXPR:
1039     case CONVERT_EXPR:
1040     case FLOAT_EXPR:
1041     case FIX_TRUNC_EXPR:
1042     case FIX_FLOOR_EXPR:
1043     case FIX_ROUND_EXPR:
1044     case FIX_CEIL_EXPR:
1045       result = build_nt (code, stabilize_reference (TREE_OPERAND (ref, 0)));
1046       break;
1047
1048     case INDIRECT_REF:
1049       result = build_nt (INDIRECT_REF,
1050                          stabilize_reference_1 (TREE_OPERAND (ref, 0)));
1051       break;
1052
1053     case COMPONENT_REF:
1054       result = build_nt (COMPONENT_REF,
1055                          stabilize_reference (TREE_OPERAND (ref, 0)),
1056                          TREE_OPERAND (ref, 1));
1057       break;
1058
1059     case BIT_FIELD_REF:
1060       result = build_nt (BIT_FIELD_REF,
1061                          stabilize_reference (TREE_OPERAND (ref, 0)),
1062                          stabilize_reference_1 (TREE_OPERAND (ref, 1)),
1063                          stabilize_reference_1 (TREE_OPERAND (ref, 2)));
1064       break;
1065
1066     case ARRAY_REF:
1067       result = build_nt (ARRAY_REF,
1068                          stabilize_reference (TREE_OPERAND (ref, 0)),
1069                          stabilize_reference_1 (TREE_OPERAND (ref, 1)));
1070       break;
1071
1072     case COMPOUND_EXPR:
1073       result = build_nt (COMPOUND_EXPR,
1074                          stabilize_reference_1 (TREE_OPERAND (ref, 0)),
1075                          stabilize_reference (TREE_OPERAND (ref, 1)));
1076       break;
1077
1078     case RTL_EXPR:
1079       result = build1 (INDIRECT_REF, TREE_TYPE (ref),
1080                        save_expr (build1 (ADDR_EXPR,
1081                                           build_pointer_type (TREE_TYPE (ref)),
1082                                           ref)));
1083       break;
1084
1085
1086     default:
1087       return save_expr (ref);
1088
1089     case ERROR_MARK:
1090       return error_mark_node;
1091     }
1092
1093   TREE_TYPE (result) = TREE_TYPE (ref);
1094   TREE_READONLY (result) = TREE_READONLY (ref);
1095   TREE_SIDE_EFFECTS (result) = TREE_SIDE_EFFECTS (ref);
1096   TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
1097
1098   return result;
1099 }
1100 #endif
1101
1102 /* A rip-off of gcc's convert.c convert_to_complex function,
1103    reworked to handle complex implemented as C structures
1104    (RECORD_TYPE with two fields, real and imaginary `r' and `i').  */
1105
1106 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1107 static tree
1108 ffecom_convert_to_complex_ (tree type, tree expr)
1109 {
1110   register enum tree_code form = TREE_CODE (TREE_TYPE (expr));
1111   tree subtype;
1112
1113   assert (TREE_CODE (type) == RECORD_TYPE);
1114
1115   subtype = TREE_TYPE (TYPE_FIELDS (type));
1116
1117   if (form == REAL_TYPE || form == INTEGER_TYPE || form == ENUMERAL_TYPE)
1118     {
1119       expr = convert (subtype, expr);
1120       return ffecom_2 (COMPLEX_EXPR, type, expr,
1121                        convert (subtype, integer_zero_node));
1122     }
1123
1124   if (form == RECORD_TYPE)
1125     {
1126       tree elt_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr)));
1127       if (TYPE_MAIN_VARIANT (elt_type) == TYPE_MAIN_VARIANT (subtype))
1128         return expr;
1129       else
1130         {
1131           expr = save_expr (expr);
1132           return ffecom_2 (COMPLEX_EXPR,
1133                            type,
1134                            convert (subtype,
1135                                     ffecom_1 (REALPART_EXPR,
1136                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1137                                               expr)),
1138                            convert (subtype,
1139                                     ffecom_1 (IMAGPART_EXPR,
1140                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1141                                               expr)));
1142         }
1143     }
1144
1145   if (form == POINTER_TYPE || form == REFERENCE_TYPE)
1146     error ("pointer value used where a complex was expected");
1147   else
1148     error ("aggregate value used where a complex was expected");
1149
1150   return ffecom_2 (COMPLEX_EXPR, type,
1151                    convert (subtype, integer_zero_node),
1152                    convert (subtype, integer_zero_node));
1153 }
1154 #endif
1155
1156 /* Like gcc's convert(), but crashes if widening might happen.  */
1157
1158 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1159 static tree
1160 ffecom_convert_narrow_ (type, expr)
1161      tree type, expr;
1162 {
1163   register tree e = expr;
1164   register enum tree_code code = TREE_CODE (type);
1165
1166   if (type == TREE_TYPE (e)
1167       || TREE_CODE (e) == ERROR_MARK)
1168     return e;
1169   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1170     return fold (build1 (NOP_EXPR, type, e));
1171   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1172       || code == ERROR_MARK)
1173     return error_mark_node;
1174   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1175     {
1176       assert ("void value not ignored as it ought to be" == NULL);
1177       return error_mark_node;
1178     }
1179   assert (code != VOID_TYPE);
1180   if ((code != RECORD_TYPE)
1181       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1182     assert ("converting COMPLEX to REAL" == NULL);
1183   assert (code != ENUMERAL_TYPE);
1184   if (code == INTEGER_TYPE)
1185     {
1186       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1187                && TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)))
1188               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1189                   && (TYPE_PRECISION (type)
1190                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1191       return fold (convert_to_integer (type, e));
1192     }
1193   if (code == POINTER_TYPE)
1194     {
1195       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1196       return fold (convert_to_pointer (type, e));
1197     }
1198   if (code == REAL_TYPE)
1199     {
1200       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1201       assert (TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)));
1202       return fold (convert_to_real (type, e));
1203     }
1204   if (code == COMPLEX_TYPE)
1205     {
1206       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1207       assert (TYPE_PRECISION (TREE_TYPE (type)) <= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1208       return fold (convert_to_complex (type, e));
1209     }
1210   if (code == RECORD_TYPE)
1211     {
1212       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1213       /* Check that at least the first field name agrees.  */
1214       assert (DECL_NAME (TYPE_FIELDS (type))
1215               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1216       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1217               <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1218       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1219           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1220         return e;
1221       return fold (ffecom_convert_to_complex_ (type, e));
1222     }
1223
1224   assert ("conversion to non-scalar type requested" == NULL);
1225   return error_mark_node;
1226 }
1227 #endif
1228
1229 /* Like gcc's convert(), but crashes if narrowing might happen.  */
1230
1231 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1232 static tree
1233 ffecom_convert_widen_ (type, expr)
1234      tree type, expr;
1235 {
1236   register tree e = expr;
1237   register enum tree_code code = TREE_CODE (type);
1238
1239   if (type == TREE_TYPE (e)
1240       || TREE_CODE (e) == ERROR_MARK)
1241     return e;
1242   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1243     return fold (build1 (NOP_EXPR, type, e));
1244   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1245       || code == ERROR_MARK)
1246     return error_mark_node;
1247   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1248     {
1249       assert ("void value not ignored as it ought to be" == NULL);
1250       return error_mark_node;
1251     }
1252   assert (code != VOID_TYPE);
1253   if ((code != RECORD_TYPE)
1254       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1255     assert ("narrowing COMPLEX to REAL" == NULL);
1256   assert (code != ENUMERAL_TYPE);
1257   if (code == INTEGER_TYPE)
1258     {
1259       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1260                && TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)))
1261               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1262                   && (TYPE_PRECISION (type)
1263                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1264       return fold (convert_to_integer (type, e));
1265     }
1266   if (code == POINTER_TYPE)
1267     {
1268       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1269       return fold (convert_to_pointer (type, e));
1270     }
1271   if (code == REAL_TYPE)
1272     {
1273       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1274       assert (TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)));
1275       return fold (convert_to_real (type, e));
1276     }
1277   if (code == COMPLEX_TYPE)
1278     {
1279       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1280       assert (TYPE_PRECISION (TREE_TYPE (type)) >= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1281       return fold (convert_to_complex (type, e));
1282     }
1283   if (code == RECORD_TYPE)
1284     {
1285       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1286       /* Check that at least the first field name agrees.  */
1287       assert (DECL_NAME (TYPE_FIELDS (type))
1288               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1289       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1290               >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1291       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1292           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1293         return e;
1294       return fold (ffecom_convert_to_complex_ (type, e));
1295     }
1296
1297   assert ("conversion to non-scalar type requested" == NULL);
1298   return error_mark_node;
1299 }
1300 #endif
1301
1302 /* Handles making a COMPLEX type, either the standard
1303    (but buggy?) gbe way, or the safer (but less elegant?)
1304    f2c way.  */
1305
1306 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1307 static tree
1308 ffecom_make_complex_type_ (tree subtype)
1309 {
1310   tree type;
1311   tree realfield;
1312   tree imagfield;
1313
1314   if (ffe_is_emulate_complex ())
1315     {
1316       type = make_node (RECORD_TYPE);
1317       realfield = ffecom_decl_field (type, NULL_TREE, "r", subtype);
1318       imagfield = ffecom_decl_field (type, realfield, "i", subtype);
1319       TYPE_FIELDS (type) = realfield;
1320       layout_type (type);
1321     }
1322   else
1323     {
1324       type = make_node (COMPLEX_TYPE);
1325       TREE_TYPE (type) = subtype;
1326       layout_type (type);
1327     }
1328
1329   return type;
1330 }
1331 #endif
1332
1333 /* Chooses either the gbe or the f2c way to build a
1334    complex constant.  */
1335
1336 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1337 static tree
1338 ffecom_build_complex_constant_ (tree type, tree realpart, tree imagpart)
1339 {
1340   tree bothparts;
1341
1342   if (ffe_is_emulate_complex ())
1343     {
1344       bothparts = build_tree_list (TYPE_FIELDS (type), realpart);
1345       TREE_CHAIN (bothparts) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), imagpart);
1346       bothparts = build (CONSTRUCTOR, type, NULL_TREE, bothparts);
1347     }
1348   else
1349     {
1350       bothparts = build_complex (type, realpart, imagpart);
1351     }
1352
1353   return bothparts;
1354 }
1355 #endif
1356
1357 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1358 static tree
1359 ffecom_arglist_expr_ (const char *c, ffebld expr)
1360 {
1361   tree list;
1362   tree *plist = &list;
1363   tree trail = NULL_TREE;       /* Append char length args here. */
1364   tree *ptrail = &trail;
1365   tree length;
1366   ffebld exprh;
1367   tree item;
1368   bool ptr = FALSE;
1369   tree wanted = NULL_TREE;
1370   static char zed[] = "0";
1371
1372   if (c == NULL)
1373     c = &zed[0];
1374
1375   while (expr != NULL)
1376     {
1377       if (*c != '\0')
1378         {
1379           ptr = FALSE;
1380           if (*c == '&')
1381             {
1382               ptr = TRUE;
1383               ++c;
1384             }
1385           switch (*(c++))
1386             {
1387             case '\0':
1388               ptr = TRUE;
1389               wanted = NULL_TREE;
1390               break;
1391
1392             case 'a':
1393               assert (ptr);
1394               wanted = NULL_TREE;
1395               break;
1396
1397             case 'c':
1398               wanted = ffecom_f2c_complex_type_node;
1399               break;
1400
1401             case 'd':
1402               wanted = ffecom_f2c_doublereal_type_node;
1403               break;
1404
1405             case 'e':
1406               wanted = ffecom_f2c_doublecomplex_type_node;
1407               break;
1408
1409             case 'f':
1410               wanted = ffecom_f2c_real_type_node;
1411               break;
1412
1413             case 'i':
1414               wanted = ffecom_f2c_integer_type_node;
1415               break;
1416
1417             case 'j':
1418               wanted = ffecom_f2c_longint_type_node;
1419               break;
1420
1421             default:
1422               assert ("bad argstring code" == NULL);
1423               wanted = NULL_TREE;
1424               break;
1425             }
1426         }
1427
1428       exprh = ffebld_head (expr);
1429       if (exprh == NULL)
1430         wanted = NULL_TREE;
1431
1432       if ((wanted == NULL_TREE)
1433           || (ptr
1434               && (TYPE_MODE
1435                   (ffecom_tree_type[ffeinfo_basictype (ffebld_info (exprh))]
1436                    [ffeinfo_kindtype (ffebld_info (exprh))])
1437                    == TYPE_MODE (wanted))))
1438         *plist
1439           = build_tree_list (NULL_TREE,
1440                              ffecom_arg_ptr_to_expr (exprh,
1441                                                      &length));
1442       else
1443         {
1444           item = ffecom_arg_expr (exprh, &length);
1445           item = ffecom_convert_widen_ (wanted, item);
1446           if (ptr)
1447             {
1448               item = ffecom_1 (ADDR_EXPR,
1449                                build_pointer_type (TREE_TYPE (item)),
1450                                item);
1451             }
1452           *plist
1453             = build_tree_list (NULL_TREE,
1454                                item);
1455         }
1456
1457       plist = &TREE_CHAIN (*plist);
1458       expr = ffebld_trail (expr);
1459       if (length != NULL_TREE)
1460         {
1461           *ptrail = build_tree_list (NULL_TREE, length);
1462           ptrail = &TREE_CHAIN (*ptrail);
1463         }
1464     }
1465
1466   /* We've run out of args in the call; if the implementation expects
1467      more, supply null pointers for them, which the implementation can
1468      check to see if an arg was omitted. */
1469
1470   while (*c != '\0' && *c != '0')
1471     {
1472       if (*c == '&')
1473         ++c;
1474       else
1475         assert ("missing arg to run-time routine!" == NULL);
1476
1477       switch (*(c++))
1478         {
1479         case '\0':
1480         case 'a':
1481         case 'c':
1482         case 'd':
1483         case 'e':
1484         case 'f':
1485         case 'i':
1486         case 'j':
1487           break;
1488
1489         default:
1490           assert ("bad arg string code" == NULL);
1491           break;
1492         }
1493       *plist
1494         = build_tree_list (NULL_TREE,
1495                            null_pointer_node);
1496       plist = &TREE_CHAIN (*plist);
1497     }
1498
1499   *plist = trail;
1500
1501   return list;
1502 }
1503 #endif
1504
1505 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1506 static tree
1507 ffecom_widest_expr_type_ (ffebld list)
1508 {
1509   ffebld item;
1510   ffebld widest = NULL;
1511   ffetype type;
1512   ffetype widest_type = NULL;
1513   tree t;
1514
1515   for (; list != NULL; list = ffebld_trail (list))
1516     {
1517       item = ffebld_head (list);
1518       if (item == NULL)
1519         continue;
1520       if ((widest != NULL)
1521           && (ffeinfo_basictype (ffebld_info (item))
1522               != ffeinfo_basictype (ffebld_info (widest))))
1523         continue;
1524       type = ffeinfo_type (ffeinfo_basictype (ffebld_info (item)),
1525                            ffeinfo_kindtype (ffebld_info (item)));
1526       if ((widest == FFEINFO_kindtypeNONE)
1527           || (ffetype_size (type)
1528               > ffetype_size (widest_type)))
1529         {
1530           widest = item;
1531           widest_type = type;
1532         }
1533     }
1534
1535   assert (widest != NULL);
1536   t = ffecom_tree_type[ffeinfo_basictype (ffebld_info (widest))]
1537     [ffeinfo_kindtype (ffebld_info (widest))];
1538   assert (t != NULL_TREE);
1539   return t;
1540 }
1541 #endif
1542
1543 /* Check whether a partial overlap between two expressions is possible.
1544
1545    Can *starting* to write a portion of expr1 change the value
1546    computed (perhaps already, *partially*) by expr2?
1547
1548    Currently, this is a concern only for a COMPLEX expr1.  But if it
1549    isn't in COMMON or local EQUIVALENCE, since we don't support
1550    aliasing of arguments, it isn't a concern.  */
1551
1552 static bool
1553 ffecom_possible_partial_overlap_ (ffebld expr1, ffebld expr2 ATTRIBUTE_UNUSED)
1554 {
1555   ffesymbol sym;
1556   ffestorag st;
1557
1558   switch (ffebld_op (expr1))
1559     {
1560     case FFEBLD_opSYMTER:
1561       sym = ffebld_symter (expr1);
1562       break;
1563
1564     case FFEBLD_opARRAYREF:
1565       if (ffebld_op (ffebld_left (expr1)) != FFEBLD_opSYMTER)
1566         return FALSE;
1567       sym = ffebld_symter (ffebld_left (expr1));
1568       break;
1569
1570     default:
1571       return FALSE;
1572     }
1573
1574   if (ffesymbol_where (sym) != FFEINFO_whereCOMMON
1575       && (ffesymbol_where (sym) != FFEINFO_whereLOCAL
1576           || ! (st = ffesymbol_storage (sym))
1577           || ! ffestorag_parent (st)))
1578     return FALSE;
1579
1580   /* It's in COMMON or local EQUIVALENCE.  */
1581
1582   return TRUE;
1583 }
1584
1585 /* Check whether dest and source might overlap.  ffebld versions of these
1586    might or might not be passed, will be NULL if not.
1587
1588    The test is really whether source_tree is modifiable and, if modified,
1589    might overlap destination such that the value(s) in the destination might
1590    change before it is finally modified.  dest_* are the canonized
1591    destination itself.  */
1592
1593 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1594 static bool
1595 ffecom_overlap_ (tree dest_decl, tree dest_offset, tree dest_size,
1596                  tree source_tree, ffebld source UNUSED,
1597                  bool scalar_arg)
1598 {
1599   tree source_decl;
1600   tree source_offset;
1601   tree source_size;
1602   tree t;
1603
1604   if (source_tree == NULL_TREE)
1605     return FALSE;
1606
1607   switch (TREE_CODE (source_tree))
1608     {
1609     case ERROR_MARK:
1610     case IDENTIFIER_NODE:
1611     case INTEGER_CST:
1612     case REAL_CST:
1613     case COMPLEX_CST:
1614     case STRING_CST:
1615     case CONST_DECL:
1616     case VAR_DECL:
1617     case RESULT_DECL:
1618     case FIELD_DECL:
1619     case MINUS_EXPR:
1620     case MULT_EXPR:
1621     case TRUNC_DIV_EXPR:
1622     case CEIL_DIV_EXPR:
1623     case FLOOR_DIV_EXPR:
1624     case ROUND_DIV_EXPR:
1625     case TRUNC_MOD_EXPR:
1626     case CEIL_MOD_EXPR:
1627     case FLOOR_MOD_EXPR:
1628     case ROUND_MOD_EXPR:
1629     case RDIV_EXPR:
1630     case EXACT_DIV_EXPR:
1631     case FIX_TRUNC_EXPR:
1632     case FIX_CEIL_EXPR:
1633     case FIX_FLOOR_EXPR:
1634     case FIX_ROUND_EXPR:
1635     case FLOAT_EXPR:
1636     case EXPON_EXPR:
1637     case NEGATE_EXPR:
1638     case MIN_EXPR:
1639     case MAX_EXPR:
1640     case ABS_EXPR:
1641     case FFS_EXPR:
1642     case LSHIFT_EXPR:
1643     case RSHIFT_EXPR:
1644     case LROTATE_EXPR:
1645     case RROTATE_EXPR:
1646     case BIT_IOR_EXPR:
1647     case BIT_XOR_EXPR:
1648     case BIT_AND_EXPR:
1649     case BIT_ANDTC_EXPR:
1650     case BIT_NOT_EXPR:
1651     case TRUTH_ANDIF_EXPR:
1652     case TRUTH_ORIF_EXPR:
1653     case TRUTH_AND_EXPR:
1654     case TRUTH_OR_EXPR:
1655     case TRUTH_XOR_EXPR:
1656     case TRUTH_NOT_EXPR:
1657     case LT_EXPR:
1658     case LE_EXPR:
1659     case GT_EXPR:
1660     case GE_EXPR:
1661     case EQ_EXPR:
1662     case NE_EXPR:
1663     case COMPLEX_EXPR:
1664     case CONJ_EXPR:
1665     case REALPART_EXPR:
1666     case IMAGPART_EXPR:
1667     case LABEL_EXPR:
1668     case COMPONENT_REF:
1669       return FALSE;
1670
1671     case COMPOUND_EXPR:
1672       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1673                               TREE_OPERAND (source_tree, 1), NULL,
1674                               scalar_arg);
1675
1676     case MODIFY_EXPR:
1677       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1678                               TREE_OPERAND (source_tree, 0), NULL,
1679                               scalar_arg);
1680
1681     case CONVERT_EXPR:
1682     case NOP_EXPR:
1683     case NON_LVALUE_EXPR:
1684     case PLUS_EXPR:
1685       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1686         return TRUE;
1687
1688       ffecom_tree_canonize_ptr_ (&source_decl, &source_offset,
1689                                  source_tree);
1690       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1691       break;
1692
1693     case COND_EXPR:
1694       return
1695         ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1696                          TREE_OPERAND (source_tree, 1), NULL,
1697                          scalar_arg)
1698           || ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1699                               TREE_OPERAND (source_tree, 2), NULL,
1700                               scalar_arg);
1701
1702
1703     case ADDR_EXPR:
1704       ffecom_tree_canonize_ref_ (&source_decl, &source_offset,
1705                                  &source_size,
1706                                  TREE_OPERAND (source_tree, 0));
1707       break;
1708
1709     case PARM_DECL:
1710       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1711         return TRUE;
1712
1713       source_decl = source_tree;
1714       source_offset = bitsize_zero_node;
1715       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1716       break;
1717
1718     case SAVE_EXPR:
1719     case REFERENCE_EXPR:
1720     case PREDECREMENT_EXPR:
1721     case PREINCREMENT_EXPR:
1722     case POSTDECREMENT_EXPR:
1723     case POSTINCREMENT_EXPR:
1724     case INDIRECT_REF:
1725     case ARRAY_REF:
1726     case CALL_EXPR:
1727     default:
1728       return TRUE;
1729     }
1730
1731   /* Come here when source_decl, source_offset, and source_size filled
1732      in appropriately.  */
1733
1734   if (source_decl == NULL_TREE)
1735     return FALSE;               /* No decl involved, so no overlap. */
1736
1737   if (source_decl != dest_decl)
1738     return FALSE;               /* Different decl, no overlap. */
1739
1740   if (TREE_CODE (dest_size) == ERROR_MARK)
1741     return TRUE;                /* Assignment into entire assumed-size
1742                                    array?  Shouldn't happen.... */
1743
1744   t = ffecom_2 (LE_EXPR, integer_type_node,
1745                 ffecom_2 (PLUS_EXPR, TREE_TYPE (dest_offset),
1746                           dest_offset,
1747                           convert (TREE_TYPE (dest_offset),
1748                                    dest_size)),
1749                 convert (TREE_TYPE (dest_offset),
1750                          source_offset));
1751
1752   if (integer_onep (t))
1753     return FALSE;               /* Destination precedes source. */
1754
1755   if (!scalar_arg
1756       || (source_size == NULL_TREE)
1757       || (TREE_CODE (source_size) == ERROR_MARK)
1758       || integer_zerop (source_size))
1759     return TRUE;                /* No way to tell if dest follows source. */
1760
1761   t = ffecom_2 (LE_EXPR, integer_type_node,
1762                 ffecom_2 (PLUS_EXPR, TREE_TYPE (source_offset),
1763                           source_offset,
1764                           convert (TREE_TYPE (source_offset),
1765                                    source_size)),
1766                 convert (TREE_TYPE (source_offset),
1767                          dest_offset));
1768
1769   if (integer_onep (t))
1770     return FALSE;               /* Destination follows source. */
1771
1772   return TRUE;          /* Destination and source overlap. */
1773 }
1774 #endif
1775
1776 /* Check whether dest might overlap any of a list of arguments or is
1777    in a COMMON area the callee might know about (and thus modify).  */
1778
1779 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1780 static bool
1781 ffecom_args_overlapping_ (tree dest_tree, ffebld dest UNUSED,
1782                           tree args, tree callee_commons,
1783                           bool scalar_args)
1784 {
1785   tree arg;
1786   tree dest_decl;
1787   tree dest_offset;
1788   tree dest_size;
1789
1790   ffecom_tree_canonize_ref_ (&dest_decl, &dest_offset, &dest_size,
1791                              dest_tree);
1792
1793   if (dest_decl == NULL_TREE)
1794     return FALSE;               /* Seems unlikely! */
1795
1796   /* If the decl cannot be determined reliably, or if its in COMMON
1797      and the callee isn't known to not futz with COMMON via other
1798      means, overlap might happen.  */
1799
1800   if ((TREE_CODE (dest_decl) == ERROR_MARK)
1801       || ((callee_commons != NULL_TREE)
1802           && TREE_PUBLIC (dest_decl)))
1803     return TRUE;
1804
1805   for (; args != NULL_TREE; args = TREE_CHAIN (args))
1806     {
1807       if (((arg = TREE_VALUE (args)) != NULL_TREE)
1808           && ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1809                               arg, NULL, scalar_args))
1810         return TRUE;
1811     }
1812
1813   return FALSE;
1814 }
1815 #endif
1816
1817 /* Build a string for a variable name as used by NAMELIST.  This means that
1818    if we're using the f2c library, we build an uppercase string, since
1819    f2c does this.  */
1820
1821 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1822 static tree
1823 ffecom_build_f2c_string_ (int i, const char *s)
1824 {
1825   if (!ffe_is_f2c_library ())
1826     return build_string (i, s);
1827
1828   {
1829     char *tmp;
1830     const char *p;
1831     char *q;
1832     char space[34];
1833     tree t;
1834
1835     if (((size_t) i) > ARRAY_SIZE (space))
1836       tmp = malloc_new_ks (malloc_pool_image (), "f2c_string", i);
1837     else
1838       tmp = &space[0];
1839
1840     for (p = s, q = tmp; *p != '\0'; ++p, ++q)
1841       *q = ffesrc_toupper (*p);
1842     *q = '\0';
1843
1844     t = build_string (i, tmp);
1845
1846     if (((size_t) i) > ARRAY_SIZE (space))
1847       malloc_kill_ks (malloc_pool_image (), tmp, i);
1848
1849     return t;
1850   }
1851 }
1852
1853 #endif
1854 /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
1855    type to just get whatever the function returns), handling the
1856    f2c value-returning convention, if required, by prepending
1857    to the arglist a pointer to a temporary to receive the return value.  */
1858
1859 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1860 static tree
1861 ffecom_call_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1862               tree type, tree args, tree dest_tree,
1863               ffebld dest, bool *dest_used, tree callee_commons,
1864               bool scalar_args, tree hook)
1865 {
1866   tree item;
1867   tree tempvar;
1868
1869   if (dest_used != NULL)
1870     *dest_used = FALSE;
1871
1872   if (is_f2c_complex)
1873     {
1874       if ((dest_used == NULL)
1875           || (dest == NULL)
1876           || (ffeinfo_basictype (ffebld_info (dest))
1877               != FFEINFO_basictypeCOMPLEX)
1878           || (ffeinfo_kindtype (ffebld_info (dest)) != kt)
1879           || ((type != NULL_TREE) && (TREE_TYPE (dest_tree) != type))
1880           || ffecom_args_overlapping_ (dest_tree, dest, args,
1881                                        callee_commons,
1882                                        scalar_args))
1883         {
1884 #ifdef HOHO
1885           tempvar = ffecom_make_tempvar (ffecom_tree_type
1886                                          [FFEINFO_basictypeCOMPLEX][kt],
1887                                          FFETARGET_charactersizeNONE,
1888                                          -1);
1889 #else
1890           tempvar = hook;
1891           assert (tempvar);
1892 #endif
1893         }
1894       else
1895         {
1896           *dest_used = TRUE;
1897           tempvar = dest_tree;
1898           type = NULL_TREE;
1899         }
1900
1901       item
1902         = build_tree_list (NULL_TREE,
1903                            ffecom_1 (ADDR_EXPR,
1904                                      build_pointer_type (TREE_TYPE (tempvar)),
1905                                      tempvar));
1906       TREE_CHAIN (item) = args;
1907
1908       item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1909                         item, NULL_TREE);
1910
1911       if (tempvar != dest_tree)
1912         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item, tempvar);
1913     }
1914   else
1915     item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1916                       args, NULL_TREE);
1917
1918   if ((type != NULL_TREE) && (TREE_TYPE (item) != type))
1919     item = ffecom_convert_narrow_ (type, item);
1920
1921   return item;
1922 }
1923 #endif
1924
1925 /* Given two arguments, transform them and make a call to the given
1926    function via ffecom_call_.  */
1927
1928 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1929 static tree
1930 ffecom_call_binop_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1931                     tree type, ffebld left, ffebld right,
1932                     tree dest_tree, ffebld dest, bool *dest_used,
1933                     tree callee_commons, bool scalar_args, tree hook)
1934 {
1935   tree left_tree;
1936   tree right_tree;
1937   tree left_length;
1938   tree right_length;
1939
1940   left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
1941   right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
1942
1943   left_tree = build_tree_list (NULL_TREE, left_tree);
1944   right_tree = build_tree_list (NULL_TREE, right_tree);
1945   TREE_CHAIN (left_tree) = right_tree;
1946
1947   if (left_length != NULL_TREE)
1948     {
1949       left_length = build_tree_list (NULL_TREE, left_length);
1950       TREE_CHAIN (right_tree) = left_length;
1951     }
1952
1953   if (right_length != NULL_TREE)
1954     {
1955       right_length = build_tree_list (NULL_TREE, right_length);
1956       if (left_length != NULL_TREE)
1957         TREE_CHAIN (left_length) = right_length;
1958       else
1959         TREE_CHAIN (right_tree) = right_length;
1960     }
1961
1962   return ffecom_call_ (fn, kt, is_f2c_complex, type, left_tree,
1963                        dest_tree, dest, dest_used, callee_commons,
1964                        scalar_args, hook);
1965 }
1966 #endif
1967
1968 /* Return ptr/length args for char subexpression
1969
1970    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
1971    subexpressions by constructing the appropriate trees for the ptr-to-
1972    character-text and length-of-character-text arguments in a calling
1973    sequence.
1974
1975    Note that if with_null is TRUE, and the expression is an opCONTER,
1976    a null byte is appended to the string.  */
1977
1978 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1979 static void
1980 ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null)
1981 {
1982   tree item;
1983   tree high;
1984   ffetargetCharacter1 val;
1985   ffetargetCharacterSize newlen;
1986
1987   switch (ffebld_op (expr))
1988     {
1989     case FFEBLD_opCONTER:
1990       val = ffebld_constant_character1 (ffebld_conter (expr));
1991       newlen = ffetarget_length_character1 (val);
1992       if (with_null)
1993         {
1994           /* Begin FFETARGET-NULL-KLUDGE.  */
1995           if (newlen != 0)
1996             ++newlen;
1997         }
1998       *length = build_int_2 (newlen, 0);
1999       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2000       high = build_int_2 (newlen, 0);
2001       TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
2002       item = build_string (newlen,
2003                            ffetarget_text_character1 (val));
2004       /* End FFETARGET-NULL-KLUDGE.  */
2005       TREE_TYPE (item)
2006         = build_type_variant
2007           (build_array_type
2008            (char_type_node,
2009             build_range_type
2010             (ffecom_f2c_ftnlen_type_node,
2011              ffecom_f2c_ftnlen_one_node,
2012              high)),
2013            1, 0);
2014       TREE_CONSTANT (item) = 1;
2015       TREE_STATIC (item) = 1;
2016       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
2017                        item);
2018       break;
2019
2020     case FFEBLD_opSYMTER:
2021       {
2022         ffesymbol s = ffebld_symter (expr);
2023
2024         item = ffesymbol_hook (s).decl_tree;
2025         if (item == NULL_TREE)
2026           {
2027             s = ffecom_sym_transform_ (s);
2028             item = ffesymbol_hook (s).decl_tree;
2029           }
2030         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
2031           {
2032             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
2033               *length = ffesymbol_hook (s).length_tree;
2034             else
2035               {
2036                 *length = build_int_2 (ffesymbol_size (s), 0);
2037                 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2038               }
2039           }
2040         else if (item == error_mark_node)
2041           *length = error_mark_node;
2042         else
2043           /* FFEINFO_kindFUNCTION.  */
2044           *length = NULL_TREE;
2045         if (!ffesymbol_hook (s).addr
2046             && (item != error_mark_node))
2047           item = ffecom_1 (ADDR_EXPR,
2048                            build_pointer_type (TREE_TYPE (item)),
2049                            item);
2050       }
2051       break;
2052
2053     case FFEBLD_opARRAYREF:
2054       {
2055         ffecom_char_args_ (&item, length, ffebld_left (expr));
2056
2057         if (item == error_mark_node || *length == error_mark_node)
2058           {
2059             item = *length = error_mark_node;
2060             break;
2061           }
2062
2063         item = ffecom_arrayref_ (item, expr, 1);
2064       }
2065       break;
2066
2067     case FFEBLD_opSUBSTR:
2068       {
2069         ffebld start;
2070         ffebld end;
2071         ffebld thing = ffebld_right (expr);
2072         tree start_tree;
2073         tree end_tree;
2074         const char *char_name;
2075         ffebld left_symter;
2076         tree array;
2077
2078         assert (ffebld_op (thing) == FFEBLD_opITEM);
2079         start = ffebld_head (thing);
2080         thing = ffebld_trail (thing);
2081         assert (ffebld_trail (thing) == NULL);
2082         end = ffebld_head (thing);
2083
2084         /* Determine name for pretty-printing range-check errors.  */
2085         for (left_symter = ffebld_left (expr);
2086              left_symter && ffebld_op (left_symter) == FFEBLD_opARRAYREF;
2087              left_symter = ffebld_left (left_symter))
2088           ;
2089         if (ffebld_op (left_symter) == FFEBLD_opSYMTER)
2090           char_name = ffesymbol_text (ffebld_symter (left_symter));
2091         else
2092           char_name = "[expr?]";
2093
2094         ffecom_char_args_ (&item, length, ffebld_left (expr));
2095
2096         if (item == error_mark_node || *length == error_mark_node)
2097           {
2098             item = *length = error_mark_node;
2099             break;
2100           }
2101
2102         array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
2103
2104         /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF.  */
2105
2106         if (start == NULL)
2107           {
2108             if (end == NULL)
2109               ;
2110             else
2111               {
2112                 end_tree = ffecom_expr (end);
2113                 if (flag_bounds_check)
2114                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2115                                                       char_name);
2116                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2117                                     end_tree);
2118
2119                 if (end_tree == error_mark_node)
2120                   {
2121                     item = *length = error_mark_node;
2122                     break;
2123                   }
2124
2125                 *length = end_tree;
2126               }
2127           }
2128         else
2129           {
2130             start_tree = ffecom_expr (start);
2131             if (flag_bounds_check)
2132               start_tree = ffecom_subscript_check_ (array, start_tree, 0, 0,
2133                                                     char_name);
2134             start_tree = convert (ffecom_f2c_ftnlen_type_node,
2135                                   start_tree);
2136
2137             if (start_tree == error_mark_node)
2138               {
2139                 item = *length = error_mark_node;
2140                 break;
2141               }
2142
2143             start_tree = ffecom_save_tree (start_tree);
2144
2145             item = ffecom_2 (PLUS_EXPR, TREE_TYPE (item),
2146                              item,
2147                              ffecom_2 (MINUS_EXPR,
2148                                        TREE_TYPE (start_tree),
2149                                        start_tree,
2150                                        ffecom_f2c_ftnlen_one_node));
2151
2152             if (end == NULL)
2153               {
2154                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2155                                     ffecom_f2c_ftnlen_one_node,
2156                                     ffecom_2 (MINUS_EXPR,
2157                                               ffecom_f2c_ftnlen_type_node,
2158                                               *length,
2159                                               start_tree));
2160               }
2161             else
2162               {
2163                 end_tree = ffecom_expr (end);
2164                 if (flag_bounds_check)
2165                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2166                                                       char_name);
2167                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2168                                     end_tree);
2169
2170                 if (end_tree == error_mark_node)
2171                   {
2172                     item = *length = error_mark_node;
2173                     break;
2174                   }
2175
2176                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2177                                     ffecom_f2c_ftnlen_one_node,
2178                                     ffecom_2 (MINUS_EXPR,
2179                                               ffecom_f2c_ftnlen_type_node,
2180                                               end_tree, start_tree));
2181               }
2182           }
2183       }
2184       break;
2185
2186     case FFEBLD_opFUNCREF:
2187       {
2188         ffesymbol s = ffebld_symter (ffebld_left (expr));
2189         tree tempvar;
2190         tree args;
2191         ffetargetCharacterSize size = ffeinfo_size (ffebld_info (expr));
2192         ffecomGfrt ix;
2193
2194         if (size == FFETARGET_charactersizeNONE)
2195           /* ~~Kludge alert!  This should someday be fixed. */
2196           size = 24;
2197
2198         *length = build_int_2 (size, 0);
2199         TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2200
2201         if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
2202             == FFEINFO_whereINTRINSIC)
2203           {
2204             if (size == 1)
2205               {
2206                 /* Invocation of an intrinsic returning CHARACTER*1.  */
2207                 item = ffecom_expr_intrinsic_ (expr, NULL_TREE,
2208                                                NULL, NULL);
2209                 break;
2210               }
2211             ix = ffeintrin_gfrt_direct (ffebld_symter_implementation (ffebld_left (expr)));
2212             assert (ix != FFECOM_gfrt);
2213             item = ffecom_gfrt_tree_ (ix);
2214           }
2215         else
2216           {
2217             ix = FFECOM_gfrt;
2218             item = ffesymbol_hook (s).decl_tree;
2219             if (item == NULL_TREE)
2220               {
2221                 s = ffecom_sym_transform_ (s);
2222                 item = ffesymbol_hook (s).decl_tree;
2223               }
2224             if (item == error_mark_node)
2225               {
2226                 item = *length = error_mark_node;
2227                 break;
2228               }
2229
2230             if (!ffesymbol_hook (s).addr)
2231               item = ffecom_1_fn (item);
2232           }
2233
2234 #ifdef HOHO
2235         tempvar = ffecom_push_tempvar (char_type_node, size, -1, TRUE);
2236 #else
2237         tempvar = ffebld_nonter_hook (expr);
2238         assert (tempvar);
2239 #endif
2240         tempvar = ffecom_1 (ADDR_EXPR,
2241                             build_pointer_type (TREE_TYPE (tempvar)),
2242                             tempvar);
2243
2244         args = build_tree_list (NULL_TREE, tempvar);
2245
2246         if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)       /* Sfunc args by value. */
2247           TREE_CHAIN (args) = ffecom_list_expr (ffebld_right (expr));
2248         else
2249           {
2250             TREE_CHAIN (args) = build_tree_list (NULL_TREE, *length);
2251             if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
2252               {
2253                 TREE_CHAIN (TREE_CHAIN (args))
2254                   = ffecom_arglist_expr_ (ffecom_gfrt_args_ (ix),
2255                                           ffebld_right (expr));
2256               }
2257             else
2258               {
2259                 TREE_CHAIN (TREE_CHAIN (args))
2260                   = ffecom_list_ptr_to_expr (ffebld_right (expr));
2261               }
2262           }
2263
2264         item = ffecom_3s (CALL_EXPR,
2265                           TREE_TYPE (TREE_TYPE (TREE_TYPE (item))),
2266                           item, args, NULL_TREE);
2267         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item,
2268                          tempvar);
2269       }
2270       break;
2271
2272     case FFEBLD_opCONVERT:
2273
2274       ffecom_char_args_ (&item, length, ffebld_left (expr));
2275
2276       if (item == error_mark_node || *length == error_mark_node)
2277         {
2278           item = *length = error_mark_node;
2279           break;
2280         }
2281
2282       if ((ffebld_size_known (ffebld_left (expr))
2283            == FFETARGET_charactersizeNONE)
2284           || (ffebld_size_known (ffebld_left (expr)) < (ffebld_size (expr))))
2285         {                       /* Possible blank-padding needed, copy into
2286                                    temporary. */
2287           tree tempvar;
2288           tree args;
2289           tree newlen;
2290
2291 #ifdef HOHO
2292           tempvar = ffecom_make_tempvar (char_type_node,
2293                                          ffebld_size (expr), -1);
2294 #else
2295           tempvar = ffebld_nonter_hook (expr);
2296           assert (tempvar);
2297 #endif
2298           tempvar = ffecom_1 (ADDR_EXPR,
2299                               build_pointer_type (TREE_TYPE (tempvar)),
2300                               tempvar);
2301
2302           newlen = build_int_2 (ffebld_size (expr), 0);
2303           TREE_TYPE (newlen) = ffecom_f2c_ftnlen_type_node;
2304
2305           args = build_tree_list (NULL_TREE, tempvar);
2306           TREE_CHAIN (args) = build_tree_list (NULL_TREE, item);
2307           TREE_CHAIN (TREE_CHAIN (args)) = build_tree_list (NULL_TREE, newlen);
2308           TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args)))
2309             = build_tree_list (NULL_TREE, *length);
2310
2311           item = ffecom_call_gfrt (FFECOM_gfrtCOPY, args, NULL_TREE);
2312           TREE_SIDE_EFFECTS (item) = 1;
2313           item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), fold (item),
2314                            tempvar);
2315           *length = newlen;
2316         }
2317       else
2318         {                       /* Just truncate the length. */
2319           *length = build_int_2 (ffebld_size (expr), 0);
2320           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2321         }
2322       break;
2323
2324     default:
2325       assert ("bad op for single char arg expr" == NULL);
2326       item = NULL_TREE;
2327       break;
2328     }
2329
2330   *xitem = item;
2331 }
2332 #endif
2333
2334 /* Check the size of the type to be sure it doesn't overflow the
2335    "portable" capacities of the compiler back end.  `dummy' types
2336    can generally overflow the normal sizes as long as the computations
2337    themselves don't overflow.  A particular target of the back end
2338    must still enforce its size requirements, though, and the back
2339    end takes care of this in stor-layout.c.  */
2340
2341 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2342 static tree
2343 ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy)
2344 {
2345   if (TREE_CODE (type) == ERROR_MARK)
2346     return type;
2347
2348   if (TYPE_SIZE (type) == NULL_TREE)
2349     return type;
2350
2351   if (TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST)
2352     return type;
2353
2354   if ((tree_int_cst_sgn (TYPE_SIZE (type)) < 0)
2355       || (!dummy && (((TREE_INT_CST_HIGH (TYPE_SIZE (type)) != 0))
2356                      || TREE_OVERFLOW (TYPE_SIZE (type)))))
2357     {
2358       ffebad_start (FFEBAD_ARRAY_LARGE);
2359       ffebad_string (ffesymbol_text (s));
2360       ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
2361       ffebad_finish ();
2362
2363       return error_mark_node;
2364     }
2365
2366   return type;
2367 }
2368 #endif
2369
2370 /* Builds a length argument (PARM_DECL).  Also wraps type in an array type
2371    where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
2372    known, length_arg if not known (FFETARGET_charactersizeNONE).  */
2373
2374 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2375 static tree
2376 ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s)
2377 {
2378   ffetargetCharacterSize sz = ffesymbol_size (s);
2379   tree highval;
2380   tree tlen;
2381   tree type = *xtype;
2382
2383   if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
2384     tlen = NULL_TREE;           /* A statement function, no length passed. */
2385   else
2386     {
2387       if (ffesymbol_where (s) == FFEINFO_whereDUMMY)
2388         tlen = ffecom_get_invented_identifier ("__g77_length_%s",
2389                                                ffesymbol_text (s));
2390       else
2391         tlen = ffecom_get_invented_identifier ("__g77_%s", "length");
2392       tlen = build_decl (PARM_DECL, tlen, ffecom_f2c_ftnlen_type_node);
2393 #if BUILT_FOR_270
2394       DECL_ARTIFICIAL (tlen) = 1;
2395 #endif
2396     }
2397
2398   if (sz == FFETARGET_charactersizeNONE)
2399     {
2400       assert (tlen != NULL_TREE);
2401       highval = variable_size (tlen);
2402     }
2403   else
2404     {
2405       highval = build_int_2 (sz, 0);
2406       TREE_TYPE (highval) = ffecom_f2c_ftnlen_type_node;
2407     }
2408
2409   type = build_array_type (type,
2410                            build_range_type (ffecom_f2c_ftnlen_type_node,
2411                                              ffecom_f2c_ftnlen_one_node,
2412                                              highval));
2413
2414   *xtype = type;
2415   return tlen;
2416 }
2417
2418 #endif
2419 /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
2420
2421    ffecomConcatList_ catlist;
2422    ffebld expr;  // expr of CHARACTER basictype.
2423    ffetargetCharacterSize max;  // max chars to gather or _...NONE if no max
2424    catlist = ffecom_concat_list_gather_(catlist,expr,max);
2425
2426    Scans expr for character subexpressions, updates and returns catlist
2427    accordingly.  */
2428
2429 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2430 static ffecomConcatList_
2431 ffecom_concat_list_gather_ (ffecomConcatList_ catlist, ffebld expr,
2432                             ffetargetCharacterSize max)
2433 {
2434   ffetargetCharacterSize sz;
2435
2436 recurse:                        /* :::::::::::::::::::: */
2437
2438   if (expr == NULL)
2439     return catlist;
2440
2441   if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen >= max))
2442     return catlist;             /* Don't append any more items. */
2443
2444   switch (ffebld_op (expr))
2445     {
2446     case FFEBLD_opCONTER:
2447     case FFEBLD_opSYMTER:
2448     case FFEBLD_opARRAYREF:
2449     case FFEBLD_opFUNCREF:
2450     case FFEBLD_opSUBSTR:
2451     case FFEBLD_opCONVERT:      /* Callers should strip this off beforehand
2452                                    if they don't need to preserve it. */
2453       if (catlist.count == catlist.max)
2454         {                       /* Make a (larger) list. */
2455           ffebld *newx;
2456           int newmax;
2457
2458           newmax = (catlist.max == 0) ? 8 : catlist.max * 2;
2459           newx = malloc_new_ks (malloc_pool_image (), "catlist",
2460                                 newmax * sizeof (newx[0]));
2461           if (catlist.max != 0)
2462             {
2463               memcpy (newx, catlist.exprs, catlist.max * sizeof (newx[0]));
2464               malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2465                               catlist.max * sizeof (newx[0]));
2466             }
2467           catlist.max = newmax;
2468           catlist.exprs = newx;
2469         }
2470       if ((sz = ffebld_size_known (expr)) != FFETARGET_charactersizeNONE)
2471         catlist.minlen += sz;
2472       else
2473         ++catlist.minlen;       /* Not true for F90; can be 0 length. */
2474       if ((sz = ffebld_size_max (expr)) == FFETARGET_charactersizeNONE)
2475         catlist.maxlen = sz;
2476       else
2477         catlist.maxlen += sz;
2478       if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen > max))
2479         {                       /* This item overlaps (or is beyond) the end
2480                                    of the destination. */
2481           switch (ffebld_op (expr))
2482             {
2483             case FFEBLD_opCONTER:
2484             case FFEBLD_opSYMTER:
2485             case FFEBLD_opARRAYREF:
2486             case FFEBLD_opFUNCREF:
2487             case FFEBLD_opSUBSTR:
2488               /* ~~Do useful truncations here. */
2489               break;
2490
2491             default:
2492               assert ("op changed or inconsistent switches!" == NULL);
2493               break;
2494             }
2495         }
2496       catlist.exprs[catlist.count++] = expr;
2497       return catlist;
2498
2499     case FFEBLD_opPAREN:
2500       expr = ffebld_left (expr);
2501       goto recurse;             /* :::::::::::::::::::: */
2502
2503     case FFEBLD_opCONCATENATE:
2504       catlist = ffecom_concat_list_gather_ (catlist, ffebld_left (expr), max);
2505       expr = ffebld_right (expr);
2506       goto recurse;             /* :::::::::::::::::::: */
2507
2508 #if 0                           /* Breaks passing small actual arg to larger
2509                                    dummy arg of sfunc */
2510     case FFEBLD_opCONVERT:
2511       expr = ffebld_left (expr);
2512       {
2513         ffetargetCharacterSize cmax;
2514
2515         cmax = catlist.len + ffebld_size_known (expr);
2516
2517         if ((max == FFETARGET_charactersizeNONE) || (max > cmax))
2518           max = cmax;
2519       }
2520       goto recurse;             /* :::::::::::::::::::: */
2521 #endif
2522
2523     case FFEBLD_opANY:
2524       return catlist;
2525
2526     default:
2527       assert ("bad op in _gather_" == NULL);
2528       return catlist;
2529     }
2530 }
2531
2532 #endif
2533 /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
2534
2535    ffecomConcatList_ catlist;
2536    ffecom_concat_list_kill_(catlist);
2537
2538    Anything allocated within the list info is deallocated.  */
2539
2540 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2541 static void
2542 ffecom_concat_list_kill_ (ffecomConcatList_ catlist)
2543 {
2544   if (catlist.max != 0)
2545     malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2546                     catlist.max * sizeof (catlist.exprs[0]));
2547 }
2548
2549 #endif
2550 /* Make list of concatenated string exprs.
2551
2552    Returns a flattened list of concatenated subexpressions given a
2553    tree of such expressions.  */
2554
2555 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2556 static ffecomConcatList_
2557 ffecom_concat_list_new_ (ffebld expr, ffetargetCharacterSize max)
2558 {
2559   ffecomConcatList_ catlist;
2560
2561   catlist.maxlen = catlist.minlen = catlist.max = catlist.count = 0;
2562   return ffecom_concat_list_gather_ (catlist, expr, max);
2563 }
2564
2565 #endif
2566
2567 /* Provide some kind of useful info on member of aggregate area,
2568    since current g77/gcc technology does not provide debug info
2569    on these members.  */
2570
2571 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2572 static void
2573 ffecom_debug_kludge_ (tree aggr, const char *aggr_type, ffesymbol member,
2574                       tree member_type UNUSED, ffetargetOffset offset)
2575 {
2576   tree value;
2577   tree decl;
2578   int len;
2579   char *buff;
2580   char space[120];
2581 #if 0
2582   tree type_id;
2583
2584   for (type_id = member_type;
2585        TREE_CODE (type_id) != IDENTIFIER_NODE;
2586        )
2587     {
2588       switch (TREE_CODE (type_id))
2589         {
2590         case INTEGER_TYPE:
2591         case REAL_TYPE:
2592           type_id = TYPE_NAME (type_id);
2593           break;
2594
2595         case ARRAY_TYPE:
2596         case COMPLEX_TYPE:
2597           type_id = TREE_TYPE (type_id);
2598           break;
2599
2600         default:
2601           assert ("no IDENTIFIER_NODE for type!" == NULL);
2602           type_id = error_mark_node;
2603           break;
2604         }
2605     }
2606 #endif
2607
2608   if (ffecom_transform_only_dummies_
2609       || !ffe_is_debug_kludge ())
2610     return;     /* Can't do this yet, maybe later. */
2611
2612   len = 60
2613     + strlen (aggr_type)
2614     + IDENTIFIER_LENGTH (DECL_NAME (aggr));
2615 #if 0
2616     + IDENTIFIER_LENGTH (type_id);
2617 #endif
2618
2619   if (((size_t) len) >= ARRAY_SIZE (space))
2620     buff = malloc_new_ks (malloc_pool_image (), "debug_kludge", len + 1);
2621   else
2622     buff = &space[0];
2623
2624   sprintf (&buff[0], "At (%s) `%s' plus %ld bytes",
2625            aggr_type,
2626            IDENTIFIER_POINTER (DECL_NAME (aggr)),
2627            (long int) offset);
2628
2629   value = build_string (len, buff);
2630   TREE_TYPE (value)
2631     = build_type_variant (build_array_type (char_type_node,
2632                                             build_range_type
2633                                             (integer_type_node,
2634                                              integer_one_node,
2635                                              build_int_2 (strlen (buff), 0))),
2636                           1, 0);
2637   decl = build_decl (VAR_DECL,
2638                      ffecom_get_identifier_ (ffesymbol_text (member)),
2639                      TREE_TYPE (value));
2640   TREE_CONSTANT (decl) = 1;
2641   TREE_STATIC (decl) = 1;
2642   DECL_INITIAL (decl) = error_mark_node;
2643   DECL_IN_SYSTEM_HEADER (decl) = 1;     /* Don't let -Wunused complain. */
2644   decl = start_decl (decl, FALSE);
2645   finish_decl (decl, value, FALSE);
2646
2647   if (buff != &space[0])
2648     malloc_kill_ks (malloc_pool_image (), buff, len + 1);
2649 }
2650 #endif
2651
2652 /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
2653
2654    ffesymbol fn;  // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
2655    int i;  // entry# for this entrypoint (used by master fn)
2656    ffecom_do_entrypoint_(s,i);
2657
2658    Makes a public entry point that calls our private master fn (already
2659    compiled).  */
2660
2661 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2662 static void
2663 ffecom_do_entry_ (ffesymbol fn, int entrynum)
2664 {
2665   ffebld item;
2666   tree type;                    /* Type of function. */
2667   tree multi_retval;            /* Var holding return value (union). */
2668   tree result;                  /* Var holding result. */
2669   ffeinfoBasictype bt;
2670   ffeinfoKindtype kt;
2671   ffeglobal g;
2672   ffeglobalType gt;
2673   bool charfunc;                /* All entry points return same type
2674                                    CHARACTER. */
2675   bool cmplxfunc;               /* Use f2c way of returning COMPLEX. */
2676   bool multi;                   /* Master fn has multiple return types. */
2677   bool altreturning = FALSE;    /* This entry point has alternate returns. */
2678   int yes;
2679   int old_lineno = lineno;
2680   const char *old_input_filename = input_filename;
2681
2682   input_filename = ffesymbol_where_filename (fn);
2683   lineno = ffesymbol_where_filelinenum (fn);
2684
2685   /* c-parse.y indeed does call suspend_momentary and not only ignores the
2686      return value, but also never calls resume_momentary, when starting an
2687      outer function (see "fndef:", "setspecs:", and so on).  So g77 does the
2688      same thing.  It shouldn't be a problem since start_function calls
2689      temporary_allocation, but it might be necessary.  If it causes a problem
2690      here, then maybe there's a bug lurking in gcc.  NOTE: This identical
2691      comment appears twice in thist file.  */
2692
2693   suspend_momentary ();
2694
2695   ffecom_doing_entry_ = TRUE;   /* Don't bother with array dimensions. */
2696
2697   switch (ffecom_primary_entry_kind_)
2698     {
2699     case FFEINFO_kindFUNCTION:
2700
2701       /* Determine actual return type for function. */
2702
2703       gt = FFEGLOBAL_typeFUNC;
2704       bt = ffesymbol_basictype (fn);
2705       kt = ffesymbol_kindtype (fn);
2706       if (bt == FFEINFO_basictypeNONE)
2707         {
2708           ffeimplic_establish_symbol (fn);
2709           if (ffesymbol_funcresult (fn) != NULL)
2710             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
2711           bt = ffesymbol_basictype (fn);
2712           kt = ffesymbol_kindtype (fn);
2713         }
2714
2715       if (bt == FFEINFO_basictypeCHARACTER)
2716         charfunc = TRUE, cmplxfunc = FALSE;
2717       else if ((bt == FFEINFO_basictypeCOMPLEX)
2718                && ffesymbol_is_f2c (fn))
2719         charfunc = FALSE, cmplxfunc = TRUE;
2720       else
2721         charfunc = cmplxfunc = FALSE;
2722
2723       if (charfunc)
2724         type = ffecom_tree_fun_type_void;
2725       else if (ffesymbol_is_f2c (fn))
2726         type = ffecom_tree_fun_type[bt][kt];
2727       else
2728         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
2729
2730       if ((type == NULL_TREE)
2731           || (TREE_TYPE (type) == NULL_TREE))
2732         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
2733
2734       multi = (ffecom_master_bt_ == FFEINFO_basictypeNONE);
2735       break;
2736
2737     case FFEINFO_kindSUBROUTINE:
2738       gt = FFEGLOBAL_typeSUBR;
2739       bt = FFEINFO_basictypeNONE;
2740       kt = FFEINFO_kindtypeNONE;
2741       if (ffecom_is_altreturning_)
2742         {                       /* Am _I_ altreturning? */
2743           for (item = ffesymbol_dummyargs (fn);
2744                item != NULL;
2745                item = ffebld_trail (item))
2746             {
2747               if (ffebld_op (ffebld_head (item)) == FFEBLD_opSTAR)
2748                 {
2749                   altreturning = TRUE;
2750                   break;
2751                 }
2752             }
2753           if (altreturning)
2754             type = ffecom_tree_subr_type;
2755           else
2756             type = ffecom_tree_fun_type_void;
2757         }
2758       else
2759         type = ffecom_tree_fun_type_void;
2760       charfunc = FALSE;
2761       cmplxfunc = FALSE;
2762       multi = FALSE;
2763       break;
2764
2765     default:
2766       assert ("say what??" == NULL);
2767       /* Fall through. */
2768     case FFEINFO_kindANY:
2769       gt = FFEGLOBAL_typeANY;
2770       bt = FFEINFO_basictypeNONE;
2771       kt = FFEINFO_kindtypeNONE;
2772       type = error_mark_node;
2773       charfunc = FALSE;
2774       cmplxfunc = FALSE;
2775       multi = FALSE;
2776       break;
2777     }
2778
2779   /* build_decl uses the current lineno and input_filename to set the decl
2780      source info.  So, I've putzed with ffestd and ffeste code to update that
2781      source info to point to the appropriate statement just before calling
2782      ffecom_do_entrypoint (which calls this fn).  */
2783
2784   start_function (ffecom_get_external_identifier_ (fn),
2785                   type,
2786                   0,            /* nested/inline */
2787                   1);           /* TREE_PUBLIC */
2788
2789   if (((g = ffesymbol_global (fn)) != NULL)
2790       && ((ffeglobal_type (g) == gt)
2791           || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
2792     {
2793       ffeglobal_set_hook (g, current_function_decl);
2794     }
2795
2796   /* Reset args in master arg list so they get retransitioned. */
2797
2798   for (item = ffecom_master_arglist_;
2799        item != NULL;
2800        item = ffebld_trail (item))
2801     {
2802       ffebld arg;
2803       ffesymbol s;
2804
2805       arg = ffebld_head (item);
2806       if (ffebld_op (arg) != FFEBLD_opSYMTER)
2807         continue;               /* Alternate return or some such thing. */
2808       s = ffebld_symter (arg);
2809       ffesymbol_hook (s).decl_tree = NULL_TREE;
2810       ffesymbol_hook (s).length_tree = NULL_TREE;
2811     }
2812
2813   /* Build dummy arg list for this entry point. */
2814
2815   yes = suspend_momentary ();
2816
2817   if (charfunc || cmplxfunc)
2818     {                           /* Prepend arg for where result goes. */
2819       tree type;
2820       tree length;
2821
2822       if (charfunc)
2823         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
2824       else
2825         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
2826
2827       result = ffecom_get_invented_identifier ("__g77_%s", "result");
2828
2829       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
2830
2831       if (charfunc)
2832         length = ffecom_char_enhance_arg_ (&type, fn);
2833       else
2834         length = NULL_TREE;     /* Not ref'd if !charfunc. */
2835
2836       type = build_pointer_type (type);
2837       result = build_decl (PARM_DECL, result, type);
2838
2839       push_parm_decl (result);
2840       ffecom_func_result_ = result;
2841
2842       if (charfunc)
2843         {
2844           push_parm_decl (length);
2845           ffecom_func_length_ = length;
2846         }
2847     }
2848   else
2849     result = DECL_RESULT (current_function_decl);
2850
2851   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn), FALSE);
2852
2853   resume_momentary (yes);
2854
2855   store_parm_decls (0);
2856
2857   ffecom_start_compstmt ();
2858   /* Disallow temp vars at this level.  */
2859   current_binding_level->prep_state = 2;
2860
2861   /* Make local var to hold return type for multi-type master fn. */
2862
2863   if (multi)
2864     {
2865       yes = suspend_momentary ();
2866
2867       multi_retval = ffecom_get_invented_identifier ("__g77_%s",
2868                                                      "multi_retval");
2869       multi_retval = build_decl (VAR_DECL, multi_retval,
2870                                  ffecom_multi_type_node_);
2871       multi_retval = start_decl (multi_retval, FALSE);
2872       finish_decl (multi_retval, NULL_TREE, FALSE);
2873
2874       resume_momentary (yes);
2875     }
2876   else
2877     multi_retval = NULL_TREE;   /* Not actually ref'd if !multi. */
2878
2879   /* Here we emit the actual code for the entry point. */
2880
2881   {
2882     ffebld list;
2883     ffebld arg;
2884     ffesymbol s;
2885     tree arglist = NULL_TREE;
2886     tree *plist = &arglist;
2887     tree prepend;
2888     tree call;
2889     tree actarg;
2890     tree master_fn;
2891
2892     /* Prepare actual arg list based on master arg list. */
2893
2894     for (list = ffecom_master_arglist_;
2895          list != NULL;
2896          list = ffebld_trail (list))
2897       {
2898         arg = ffebld_head (list);
2899         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2900           continue;
2901         s = ffebld_symter (arg);
2902         if (ffesymbol_hook (s).decl_tree == NULL_TREE
2903             || ffesymbol_hook (s).decl_tree == error_mark_node)
2904           actarg = null_pointer_node;   /* We don't have this arg. */
2905         else
2906           actarg = ffesymbol_hook (s).decl_tree;
2907         *plist = build_tree_list (NULL_TREE, actarg);
2908         plist = &TREE_CHAIN (*plist);
2909       }
2910
2911     /* This code appends the length arguments for character
2912        variables/arrays.  */
2913
2914     for (list = ffecom_master_arglist_;
2915          list != NULL;
2916          list = ffebld_trail (list))
2917       {
2918         arg = ffebld_head (list);
2919         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2920           continue;
2921         s = ffebld_symter (arg);
2922         if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
2923           continue;             /* Only looking for CHARACTER arguments. */
2924         if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
2925           continue;             /* Only looking for variables and arrays. */
2926         if (ffesymbol_hook (s).length_tree == NULL_TREE
2927             || ffesymbol_hook (s).length_tree == error_mark_node)
2928           actarg = ffecom_f2c_ftnlen_zero_node; /* We don't have this arg. */
2929         else
2930           actarg = ffesymbol_hook (s).length_tree;
2931         *plist = build_tree_list (NULL_TREE, actarg);
2932         plist = &TREE_CHAIN (*plist);
2933       }
2934
2935     /* Prepend character-value return info to actual arg list. */
2936
2937     if (charfunc)
2938       {
2939         prepend = build_tree_list (NULL_TREE, ffecom_func_result_);
2940         TREE_CHAIN (prepend)
2941           = build_tree_list (NULL_TREE, ffecom_func_length_);
2942         TREE_CHAIN (TREE_CHAIN (prepend)) = arglist;
2943         arglist = prepend;
2944       }
2945
2946     /* Prepend multi-type return value to actual arg list. */
2947
2948     if (multi)
2949       {
2950         prepend
2951           = build_tree_list (NULL_TREE,
2952                              ffecom_1 (ADDR_EXPR,
2953                               build_pointer_type (TREE_TYPE (multi_retval)),
2954                                        multi_retval));
2955         TREE_CHAIN (prepend) = arglist;
2956         arglist = prepend;
2957       }
2958
2959     /* Prepend my entry-point number to the actual arg list. */
2960
2961     prepend = build_tree_list (NULL_TREE, build_int_2 (entrynum, 0));
2962     TREE_CHAIN (prepend) = arglist;
2963     arglist = prepend;
2964
2965     /* Build the call to the master function. */
2966
2967     master_fn = ffecom_1_fn (ffecom_previous_function_decl_);
2968     call = ffecom_3s (CALL_EXPR,
2969                       TREE_TYPE (TREE_TYPE (TREE_TYPE (master_fn))),
2970                       master_fn, arglist, NULL_TREE);
2971
2972     /* Decide whether the master function is a function or subroutine, and
2973        handle the return value for my entry point. */
2974
2975     if (charfunc || ((ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
2976                      && !altreturning))
2977       {
2978         expand_expr_stmt (call);
2979         expand_null_return ();
2980       }
2981     else if (multi && cmplxfunc)
2982       {
2983         expand_expr_stmt (call);
2984         result
2985           = ffecom_1 (INDIRECT_REF,
2986                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2987                       result);
2988         result = ffecom_modify (NULL_TREE, result,
2989                                 ffecom_2 (COMPONENT_REF, TREE_TYPE (result),
2990                                           multi_retval,
2991                                           ffecom_multi_fields_[bt][kt]));
2992         expand_expr_stmt (result);
2993         expand_null_return ();
2994       }
2995     else if (multi)
2996       {
2997         expand_expr_stmt (call);
2998         result
2999           = ffecom_modify (NULL_TREE, result,
3000                            convert (TREE_TYPE (result),
3001                                     ffecom_2 (COMPONENT_REF,
3002                                               ffecom_tree_type[bt][kt],
3003                                               multi_retval,
3004                                               ffecom_multi_fields_[bt][kt])));
3005         expand_return (result);
3006       }
3007     else if (cmplxfunc)
3008       {
3009         result
3010           = ffecom_1 (INDIRECT_REF,
3011                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
3012                       result);
3013         result = ffecom_modify (NULL_TREE, result, call);
3014         expand_expr_stmt (result);
3015         expand_null_return ();
3016       }
3017     else
3018       {
3019         result = ffecom_modify (NULL_TREE,
3020                                 result,
3021                                 convert (TREE_TYPE (result),
3022                                          call));
3023         expand_return (result);
3024       }
3025
3026     clear_momentary ();
3027   }
3028
3029   ffecom_end_compstmt ();
3030
3031   finish_function (0);
3032
3033   lineno = old_lineno;
3034   input_filename = old_input_filename;
3035
3036   ffecom_doing_entry_ = FALSE;
3037 }
3038
3039 #endif
3040 /* Transform expr into gcc tree with possible destination
3041
3042    Recursive descent on expr while making corresponding tree nodes and
3043    attaching type info and such.  If destination supplied and compatible
3044    with temporary that would be made in certain cases, temporary isn't
3045    made, destination used instead, and dest_used flag set TRUE.  */
3046
3047 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3048 static tree
3049 ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
3050               bool *dest_used, bool assignp, bool widenp)
3051 {
3052   tree item;
3053   tree list;
3054   tree args;
3055   ffeinfoBasictype bt;
3056   ffeinfoKindtype kt;
3057   tree t;
3058   tree dt;                      /* decl_tree for an ffesymbol. */
3059   tree tree_type, tree_type_x;
3060   tree left, right;
3061   ffesymbol s;
3062   enum tree_code code;
3063
3064   assert (expr != NULL);
3065
3066   if (dest_used != NULL)
3067     *dest_used = FALSE;
3068
3069   bt = ffeinfo_basictype (ffebld_info (expr));
3070   kt = ffeinfo_kindtype (ffebld_info (expr));
3071   tree_type = ffecom_tree_type[bt][kt];
3072
3073   /* Widen integral arithmetic as desired while preserving signedness.  */
3074   tree_type_x = NULL_TREE;
3075   if (widenp && tree_type
3076       && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
3077       && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
3078     tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
3079
3080   switch (ffebld_op (expr))
3081     {
3082     case FFEBLD_opACCTER:
3083       {
3084         ffebitCount i;
3085         ffebit bits = ffebld_accter_bits (expr);
3086         ffetargetOffset source_offset = 0;
3087         ffetargetOffset dest_offset = ffebld_accter_pad (expr);
3088         tree purpose;
3089
3090         assert (dest_offset == 0
3091                 || (bt == FFEINFO_basictypeCHARACTER
3092                     && kt == FFEINFO_kindtypeCHARACTER1));
3093
3094         list = item = NULL;
3095         for (;;)
3096           {
3097             ffebldConstantUnion cu;
3098             ffebitCount length;
3099             bool value;
3100             ffebldConstantArray ca = ffebld_accter (expr);
3101
3102             ffebit_test (bits, source_offset, &value, &length);
3103             if (length == 0)
3104               break;
3105
3106             if (value)
3107               {
3108                 for (i = 0; i < length; ++i)
3109                   {
3110                     cu = ffebld_constantarray_get (ca, bt, kt,
3111                                                    source_offset + i);
3112
3113                     t = ffecom_constantunion (&cu, bt, kt, tree_type);
3114
3115                     if (i == 0
3116                         && dest_offset != 0)
3117                       purpose = build_int_2 (dest_offset, 0);
3118                     else
3119                       purpose = NULL_TREE;
3120
3121                     if (list == NULL_TREE)
3122                       list = item = build_tree_list (purpose, t);
3123                     else
3124                       {
3125                         TREE_CHAIN (item) = build_tree_list (purpose, t);
3126                         item = TREE_CHAIN (item);
3127                       }
3128                   }
3129               }
3130             source_offset += length;
3131             dest_offset += length;
3132           }
3133       }
3134
3135       item = build_int_2 ((ffebld_accter_size (expr)
3136                            + ffebld_accter_pad (expr)) - 1, 0);
3137       ffebit_kill (ffebld_accter_bits (expr));
3138       TREE_TYPE (item) = ffecom_integer_type_node;
3139       item
3140         = build_array_type
3141           (tree_type,
3142            build_range_type (ffecom_integer_type_node,
3143                              ffecom_integer_zero_node,
3144                              item));
3145       list = build (CONSTRUCTOR, item, NULL_TREE, list);
3146       TREE_CONSTANT (list) = 1;
3147       TREE_STATIC (list) = 1;
3148       return list;
3149
3150     case FFEBLD_opARRTER:
3151       {
3152         ffetargetOffset i;
3153
3154         list = NULL_TREE;
3155         if (ffebld_arrter_pad (expr) == 0)
3156           item = NULL_TREE;
3157         else
3158           {
3159             assert (bt == FFEINFO_basictypeCHARACTER
3160                     && kt == FFEINFO_kindtypeCHARACTER1);
3161
3162             /* Becomes PURPOSE first time through loop.  */
3163             item = build_int_2 (ffebld_arrter_pad (expr), 0);
3164           }
3165
3166         for (i = 0; i < ffebld_arrter_size (expr); ++i)
3167           {
3168             ffebldConstantUnion cu
3169             = ffebld_constantarray_get (ffebld_arrter (expr), bt, kt, i);
3170
3171             t = ffecom_constantunion (&cu, bt, kt, tree_type);
3172
3173             if (list == NULL_TREE)
3174               /* Assume item is PURPOSE first time through loop.  */
3175               list = item = build_tree_list (item, t);
3176             else
3177               {
3178                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
3179                 item = TREE_CHAIN (item);
3180               }
3181           }
3182       }
3183
3184       item = build_int_2 ((ffebld_arrter_size (expr)
3185                           + ffebld_arrter_pad (expr)) - 1, 0);
3186       TREE_TYPE (item) = ffecom_integer_type_node;
3187       item
3188         = build_array_type
3189           (tree_type,
3190            build_range_type (ffecom_integer_type_node,
3191                              ffecom_integer_zero_node,
3192                              item));
3193       list = build (CONSTRUCTOR, item, NULL_TREE, list);
3194       TREE_CONSTANT (list) = 1;
3195       TREE_STATIC (list) = 1;
3196       return list;
3197
3198     case FFEBLD_opCONTER:
3199       assert (ffebld_conter_pad (expr) == 0);
3200       item
3201         = ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr)),
3202                                 bt, kt, tree_type);
3203       return item;
3204
3205     case FFEBLD_opSYMTER:
3206       if ((ffebld_symter_generic (expr) != FFEINTRIN_genNONE)
3207           || (ffebld_symter_specific (expr) != FFEINTRIN_specNONE))
3208         return ffecom_ptr_to_expr (expr);       /* Same as %REF(intrinsic). */
3209       s = ffebld_symter (expr);
3210       t = ffesymbol_hook (s).decl_tree;
3211
3212       if (assignp)
3213         {                       /* ASSIGN'ed-label expr. */
3214           if (ffe_is_ugly_assign ())
3215             {
3216               /* User explicitly wants ASSIGN'ed variables to be at the same
3217                  memory address as the variables when used in non-ASSIGN
3218                  contexts.  That can make old, arcane, non-standard code
3219                  work, but don't try to do it when a pointer wouldn't fit
3220                  in the normal variable (take other approach, and warn,
3221                  instead).  */
3222
3223               if (t == NULL_TREE)
3224                 {
3225                   s = ffecom_sym_transform_ (s);
3226                   t = ffesymbol_hook (s).decl_tree;
3227                   assert (t != NULL_TREE);
3228                 }
3229
3230               if (t == error_mark_node)
3231                 return t;
3232
3233               if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t)))
3234                   >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
3235                 {
3236                   if (ffesymbol_hook (s).addr)
3237                     t = ffecom_1 (INDIRECT_REF,
3238                                   TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3239                   return t;
3240                 }
3241
3242               if (ffesymbol_hook (s).assign_tree == NULL_TREE)
3243                 {
3244                   ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling",
3245                                     FFEBAD_severityWARNING);
3246                   ffebad_string (ffesymbol_text (s));
3247                   ffebad_here (0, ffesymbol_where_line (s),
3248                                ffesymbol_where_column (s));
3249                   ffebad_finish ();
3250                 }
3251             }
3252
3253           /* Don't use the normal variable's tree for ASSIGN, though mark
3254              it as in the system header (housekeeping).  Use an explicit,
3255              specially created sibling that is known to be wide enough
3256              to hold pointers to labels.  */
3257
3258           if (t != NULL_TREE
3259               && TREE_CODE (t) == VAR_DECL)
3260             DECL_IN_SYSTEM_HEADER (t) = 1;      /* Don't let -Wunused complain. */
3261
3262           t = ffesymbol_hook (s).assign_tree;
3263           if (t == NULL_TREE)
3264             {
3265               s = ffecom_sym_transform_assign_ (s);
3266               t = ffesymbol_hook (s).assign_tree;
3267               assert (t != NULL_TREE);
3268             }
3269         }
3270       else
3271         {
3272           if (t == NULL_TREE)
3273             {
3274               s = ffecom_sym_transform_ (s);
3275               t = ffesymbol_hook (s).decl_tree;
3276               assert (t != NULL_TREE);
3277             }
3278           if (ffesymbol_hook (s).addr)
3279             t = ffecom_1 (INDIRECT_REF,
3280                           TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3281         }
3282       return t;
3283
3284     case FFEBLD_opARRAYREF:
3285       return ffecom_arrayref_ (NULL_TREE, expr, 0);
3286
3287     case FFEBLD_opUPLUS:
3288       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3289       return ffecom_1 (NOP_EXPR, tree_type, left);
3290
3291     case FFEBLD_opPAREN:
3292       /* ~~~Make sure Fortran rules respected here */
3293       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3294       return ffecom_1 (NOP_EXPR, tree_type, left);
3295
3296     case FFEBLD_opUMINUS:
3297       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3298       if (tree_type_x)
3299         {
3300           tree_type = tree_type_x;
3301           left = convert (tree_type, left);
3302         }
3303       return ffecom_1 (NEGATE_EXPR, tree_type, left);
3304
3305     case FFEBLD_opADD:
3306       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3307       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3308       if (tree_type_x)
3309         {
3310           tree_type = tree_type_x;
3311           left = convert (tree_type, left);
3312           right = convert (tree_type, right);
3313         }
3314       return ffecom_2 (PLUS_EXPR, tree_type, left, right);
3315
3316     case FFEBLD_opSUBTRACT:
3317       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3318       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3319       if (tree_type_x)
3320         {
3321           tree_type = tree_type_x;
3322           left = convert (tree_type, left);
3323           right = convert (tree_type, right);
3324         }
3325       return ffecom_2 (MINUS_EXPR, tree_type, left, right);
3326
3327     case FFEBLD_opMULTIPLY:
3328       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3329       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3330       if (tree_type_x)
3331         {
3332           tree_type = tree_type_x;
3333           left = convert (tree_type, left);
3334           right = convert (tree_type, right);
3335         }
3336       return ffecom_2 (MULT_EXPR, tree_type, left, right);
3337
3338     case FFEBLD_opDIVIDE:
3339       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3340       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3341       if (tree_type_x)
3342         {
3343           tree_type = tree_type_x;
3344           left = convert (tree_type, left);
3345           right = convert (tree_type, right);
3346         }
3347       return ffecom_tree_divide_ (tree_type, left, right,
3348                                   dest_tree, dest, dest_used,
3349                                   ffebld_nonter_hook (expr));
3350
3351     case FFEBLD_opPOWER:
3352       {
3353         ffebld left = ffebld_left (expr);
3354         ffebld right = ffebld_right (expr);
3355         ffecomGfrt code;
3356         ffeinfoKindtype rtkt;
3357         ffeinfoKindtype ltkt;
3358
3359         switch (ffeinfo_basictype (ffebld_info (right)))
3360           {
3361           case FFEINFO_basictypeINTEGER:
3362             if (1 || optimize)
3363               {
3364                 item = ffecom_expr_power_integer_ (expr);
3365                 if (item != NULL_TREE)
3366                   return item;
3367               }
3368
3369             rtkt = FFEINFO_kindtypeINTEGER1;
3370             switch (ffeinfo_basictype (ffebld_info (left)))
3371               {
3372               case FFEINFO_basictypeINTEGER:
3373                 if ((ffeinfo_kindtype (ffebld_info (left))
3374                     == FFEINFO_kindtypeINTEGER4)
3375                     || (ffeinfo_kindtype (ffebld_info (right))
3376                         == FFEINFO_kindtypeINTEGER4))
3377                   {
3378                     code = FFECOM_gfrtPOW_QQ;
3379                     ltkt = FFEINFO_kindtypeINTEGER4;
3380                     rtkt = FFEINFO_kindtypeINTEGER4;
3381                   }
3382                 else
3383                   {
3384                     code = FFECOM_gfrtPOW_II;
3385                     ltkt = FFEINFO_kindtypeINTEGER1;
3386                   }
3387                 break;
3388
3389               case FFEINFO_basictypeREAL:
3390                 if (ffeinfo_kindtype (ffebld_info (left))
3391                     == FFEINFO_kindtypeREAL1)
3392                   {
3393                     code = FFECOM_gfrtPOW_RI;
3394                     ltkt = FFEINFO_kindtypeREAL1;
3395                   }
3396                 else
3397                   {
3398                     code = FFECOM_gfrtPOW_DI;
3399                     ltkt = FFEINFO_kindtypeREAL2;
3400                   }
3401                 break;
3402
3403               case FFEINFO_basictypeCOMPLEX:
3404                 if (ffeinfo_kindtype (ffebld_info (left))
3405                     == FFEINFO_kindtypeREAL1)
3406                   {
3407                     code = FFECOM_gfrtPOW_CI;   /* Overlapping result okay. */
3408                     ltkt = FFEINFO_kindtypeREAL1;
3409                   }
3410                 else
3411                   {
3412                     code = FFECOM_gfrtPOW_ZI;   /* Overlapping result okay. */
3413                     ltkt = FFEINFO_kindtypeREAL2;
3414                   }
3415                 break;
3416
3417               default:
3418                 assert ("bad pow_*i" == NULL);
3419                 code = FFECOM_gfrtPOW_CI;       /* Overlapping result okay. */
3420                 ltkt = FFEINFO_kindtypeREAL1;
3421                 break;
3422               }
3423             if (ffeinfo_kindtype (ffebld_info (left)) != ltkt)
3424               left = ffeexpr_convert (left, NULL, NULL,
3425                                       ffeinfo_basictype (ffebld_info (left)),
3426                                       ltkt, 0,
3427                                       FFETARGET_charactersizeNONE,
3428                                       FFEEXPR_contextLET);
3429             if (ffeinfo_kindtype (ffebld_info (right)) != rtkt)
3430               right = ffeexpr_convert (right, NULL, NULL,
3431                                        FFEINFO_basictypeINTEGER,
3432                                        rtkt, 0,
3433                                        FFETARGET_charactersizeNONE,
3434                                        FFEEXPR_contextLET);
3435             break;
3436
3437           case FFEINFO_basictypeREAL:
3438             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3439               left = ffeexpr_convert (left, NULL, NULL, FFEINFO_basictypeREAL,
3440                                       FFEINFO_kindtypeREALDOUBLE, 0,
3441                                       FFETARGET_charactersizeNONE,
3442                                       FFEEXPR_contextLET);
3443             if (ffeinfo_kindtype (ffebld_info (right))
3444                 == FFEINFO_kindtypeREAL1)
3445               right = ffeexpr_convert (right, NULL, NULL,
3446                                        FFEINFO_basictypeREAL,
3447                                        FFEINFO_kindtypeREALDOUBLE, 0,
3448                                        FFETARGET_charactersizeNONE,
3449                                        FFEEXPR_contextLET);
3450             code = FFECOM_gfrtPOW_DD;
3451             break;
3452
3453           case FFEINFO_basictypeCOMPLEX:
3454             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3455               left = ffeexpr_convert (left, NULL, NULL,
3456                                       FFEINFO_basictypeCOMPLEX,
3457                                       FFEINFO_kindtypeREALDOUBLE, 0,
3458                                       FFETARGET_charactersizeNONE,
3459                                       FFEEXPR_contextLET);
3460             if (ffeinfo_kindtype (ffebld_info (right))
3461                 == FFEINFO_kindtypeREAL1)
3462               right = ffeexpr_convert (right, NULL, NULL,
3463                                        FFEINFO_basictypeCOMPLEX,
3464                                        FFEINFO_kindtypeREALDOUBLE, 0,
3465                                        FFETARGET_charactersizeNONE,
3466                                        FFEEXPR_contextLET);
3467             code = FFECOM_gfrtPOW_ZZ;   /* Overlapping result okay. */
3468             break;
3469
3470           default:
3471             assert ("bad pow_x*" == NULL);
3472             code = FFECOM_gfrtPOW_II;
3473             break;
3474           }
3475         return ffecom_call_binop_ (ffecom_gfrt_tree_ (code),
3476                                    ffecom_gfrt_kindtype (code),
3477                                    (ffe_is_f2c_library ()
3478                                     && ffecom_gfrt_complex_[code]),
3479                                    tree_type, left, right,
3480                                    dest_tree, dest, dest_used,
3481                                    NULL_TREE, FALSE,
3482                                    ffebld_nonter_hook (expr));
3483       }
3484
3485     case FFEBLD_opNOT:
3486       switch (bt)
3487         {
3488         case FFEINFO_basictypeLOGICAL:
3489           item = ffecom_truth_value_invert (ffecom_expr (ffebld_left (expr)));
3490           return convert (tree_type, item);
3491
3492         case FFEINFO_basictypeINTEGER:
3493           return ffecom_1 (BIT_NOT_EXPR, tree_type,
3494                            ffecom_expr (ffebld_left (expr)));
3495
3496         default:
3497           assert ("NOT bad basictype" == NULL);
3498           /* Fall through. */
3499         case FFEINFO_basictypeANY:
3500           return error_mark_node;
3501         }
3502       break;
3503
3504     case FFEBLD_opFUNCREF:
3505       assert (ffeinfo_basictype (ffebld_info (expr))
3506               != FFEINFO_basictypeCHARACTER);
3507       /* Fall through.   */
3508     case FFEBLD_opSUBRREF:
3509       if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
3510           == FFEINFO_whereINTRINSIC)
3511         {                       /* Invocation of an intrinsic. */
3512           item = ffecom_expr_intrinsic_ (expr, dest_tree, dest,
3513                                          dest_used);
3514           return item;
3515         }
3516       s = ffebld_symter (ffebld_left (expr));
3517       dt = ffesymbol_hook (s).decl_tree;
3518       if (dt == NULL_TREE)
3519         {
3520           s = ffecom_sym_transform_ (s);
3521           dt = ffesymbol_hook (s).decl_tree;
3522         }
3523       if (dt == error_mark_node)
3524         return dt;
3525
3526       if (ffesymbol_hook (s).addr)
3527         item = dt;
3528       else
3529         item = ffecom_1_fn (dt);
3530
3531       if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
3532         args = ffecom_list_expr (ffebld_right (expr));
3533       else
3534         args = ffecom_list_ptr_to_expr (ffebld_right (expr));
3535
3536       if (args == error_mark_node)
3537         return error_mark_node;
3538
3539       item = ffecom_call_ (item, kt,
3540                            ffesymbol_is_f2c (s)
3541                            && (bt == FFEINFO_basictypeCOMPLEX)
3542                            && (ffesymbol_where (s)
3543                                != FFEINFO_whereCONSTANT),
3544                            tree_type,
3545                            args,
3546                            dest_tree, dest, dest_used,
3547                            error_mark_node, FALSE,
3548                            ffebld_nonter_hook (expr));
3549       TREE_SIDE_EFFECTS (item) = 1;
3550       return item;
3551
3552     case FFEBLD_opAND:
3553       switch (bt)
3554         {
3555         case FFEINFO_basictypeLOGICAL:
3556           item
3557             = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3558                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3559                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3560           return convert (tree_type, item);
3561
3562         case FFEINFO_basictypeINTEGER:
3563           return ffecom_2 (BIT_AND_EXPR, tree_type,
3564                            ffecom_expr (ffebld_left (expr)),
3565                            ffecom_expr (ffebld_right (expr)));
3566
3567         default:
3568           assert ("AND bad basictype" == NULL);
3569           /* Fall through. */
3570         case FFEINFO_basictypeANY:
3571           return error_mark_node;
3572         }
3573       break;
3574
3575     case FFEBLD_opOR:
3576       switch (bt)
3577         {
3578         case FFEINFO_basictypeLOGICAL:
3579           item
3580             = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
3581                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3582                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3583           return convert (tree_type, item);
3584
3585         case FFEINFO_basictypeINTEGER:
3586           return ffecom_2 (BIT_IOR_EXPR, tree_type,
3587                            ffecom_expr (ffebld_left (expr)),
3588                            ffecom_expr (ffebld_right (expr)));
3589
3590         default:
3591           assert ("OR bad basictype" == NULL);
3592           /* Fall through. */
3593         case FFEINFO_basictypeANY:
3594           return error_mark_node;
3595         }
3596       break;
3597
3598     case FFEBLD_opXOR:
3599     case FFEBLD_opNEQV:
3600       switch (bt)
3601         {
3602         case FFEINFO_basictypeLOGICAL:
3603           item
3604             = ffecom_2 (NE_EXPR, integer_type_node,
3605                         ffecom_expr (ffebld_left (expr)),
3606                         ffecom_expr (ffebld_right (expr)));
3607           return convert (tree_type, ffecom_truth_value (item));
3608
3609         case FFEINFO_basictypeINTEGER:
3610           return ffecom_2 (BIT_XOR_EXPR, tree_type,
3611                            ffecom_expr (ffebld_left (expr)),
3612                            ffecom_expr (ffebld_right (expr)));
3613
3614         default:
3615           assert ("XOR/NEQV bad basictype" == NULL);
3616           /* Fall through. */
3617         case FFEINFO_basictypeANY:
3618           return error_mark_node;
3619         }
3620       break;
3621
3622     case FFEBLD_opEQV:
3623       switch (bt)
3624         {
3625         case FFEINFO_basictypeLOGICAL:
3626           item
3627             = ffecom_2 (EQ_EXPR, integer_type_node,
3628                         ffecom_expr (ffebld_left (expr)),
3629                         ffecom_expr (ffebld_right (expr)));
3630           return convert (tree_type, ffecom_truth_value (item));
3631
3632         case FFEINFO_basictypeINTEGER:
3633           return
3634             ffecom_1 (BIT_NOT_EXPR, tree_type,
3635                       ffecom_2 (BIT_XOR_EXPR, tree_type,
3636                                 ffecom_expr (ffebld_left (expr)),
3637                                 ffecom_expr (ffebld_right (expr))));
3638
3639         default:
3640           assert ("EQV bad basictype" == NULL);
3641           /* Fall through. */
3642         case FFEINFO_basictypeANY:
3643           return error_mark_node;
3644         }
3645       break;
3646
3647     case FFEBLD_opCONVERT:
3648       if (ffebld_op (ffebld_left (expr)) == FFEBLD_opANY)
3649         return error_mark_node;
3650
3651       switch (bt)
3652         {
3653         case FFEINFO_basictypeLOGICAL:
3654         case FFEINFO_basictypeINTEGER:
3655         case FFEINFO_basictypeREAL:
3656           return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3657
3658         case FFEINFO_basictypeCOMPLEX:
3659           switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3660             {
3661             case FFEINFO_basictypeINTEGER:
3662             case FFEINFO_basictypeLOGICAL:
3663             case FFEINFO_basictypeREAL:
3664               item = ffecom_expr (ffebld_left (expr));
3665               if (item == error_mark_node)
3666                 return error_mark_node;
3667               /* convert() takes care of converting to the subtype first,
3668                  at least in gcc-2.7.2. */
3669               item = convert (tree_type, item);
3670               return item;
3671
3672             case FFEINFO_basictypeCOMPLEX:
3673               return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3674
3675             default:
3676               assert ("CONVERT COMPLEX bad basictype" == NULL);
3677               /* Fall through. */
3678             case FFEINFO_basictypeANY:
3679               return error_mark_node;
3680             }
3681           break;
3682
3683         default:
3684           assert ("CONVERT bad basictype" == NULL);
3685           /* Fall through. */
3686         case FFEINFO_basictypeANY:
3687           return error_mark_node;
3688         }
3689       break;
3690
3691     case FFEBLD_opLT:
3692       code = LT_EXPR;
3693       goto relational;          /* :::::::::::::::::::: */
3694
3695     case FFEBLD_opLE:
3696       code = LE_EXPR;
3697       goto relational;          /* :::::::::::::::::::: */
3698
3699     case FFEBLD_opEQ:
3700       code = EQ_EXPR;
3701       goto relational;          /* :::::::::::::::::::: */
3702
3703     case FFEBLD_opNE:
3704       code = NE_EXPR;
3705       goto relational;          /* :::::::::::::::::::: */
3706
3707     case FFEBLD_opGT:
3708       code = GT_EXPR;
3709       goto relational;          /* :::::::::::::::::::: */
3710
3711     case FFEBLD_opGE:
3712       code = GE_EXPR;
3713
3714     relational:         /* :::::::::::::::::::: */
3715       switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3716         {
3717         case FFEINFO_basictypeLOGICAL:
3718         case FFEINFO_basictypeINTEGER:
3719         case FFEINFO_basictypeREAL:
3720           item = ffecom_2 (code, integer_type_node,
3721                            ffecom_expr (ffebld_left (expr)),
3722                            ffecom_expr (ffebld_right (expr)));
3723           return convert (tree_type, item);
3724
3725         case FFEINFO_basictypeCOMPLEX:
3726           assert (code == EQ_EXPR || code == NE_EXPR);
3727           {
3728             tree real_type;
3729             tree arg1 = ffecom_expr (ffebld_left (expr));
3730             tree arg2 = ffecom_expr (ffebld_right (expr));
3731
3732             if (arg1 == error_mark_node || arg2 == error_mark_node)
3733               return error_mark_node;
3734
3735             arg1 = ffecom_save_tree (arg1);
3736             arg2 = ffecom_save_tree (arg2);
3737
3738             if (TREE_CODE (TREE_TYPE (arg1)) == COMPLEX_TYPE)
3739               {
3740                 real_type = TREE_TYPE (TREE_TYPE (arg1));
3741                 assert (real_type == TREE_TYPE (TREE_TYPE (arg2)));
3742               }
3743             else
3744               {
3745                 real_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg1)));
3746                 assert (real_type == TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg2))));
3747               }
3748
3749             item
3750               = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3751                           ffecom_2 (EQ_EXPR, integer_type_node,
3752                                   ffecom_1 (REALPART_EXPR, real_type, arg1),
3753                                  ffecom_1 (REALPART_EXPR, real_type, arg2)),
3754                           ffecom_2 (EQ_EXPR, integer_type_node,
3755                                   ffecom_1 (IMAGPART_EXPR, real_type, arg1),
3756                                     ffecom_1 (IMAGPART_EXPR, real_type,
3757                                               arg2)));
3758             if (code == EQ_EXPR)
3759               item = ffecom_truth_value (item);
3760             else
3761               item = ffecom_truth_value_invert (item);
3762             return convert (tree_type, item);
3763           }
3764
3765         case FFEINFO_basictypeCHARACTER:
3766           {
3767             ffebld left = ffebld_left (expr);
3768             ffebld right = ffebld_right (expr);
3769             tree left_tree;
3770             tree right_tree;
3771             tree left_length;
3772             tree right_length;
3773
3774             /* f2c run-time functions do the implicit blank-padding for us,
3775                so we don't usually have to implement blank-padding ourselves.
3776                (The exception is when we pass an argument to a separately
3777                compiled statement function -- if we know the arg is not the
3778                same length as the dummy, we must truncate or extend it.  If
3779                we "inline" statement functions, that necessity goes away as
3780                well.)
3781
3782                Strip off the CONVERT operators that blank-pad.  (Truncation by
3783                CONVERT shouldn't happen here, but it can happen in
3784                assignments.) */
3785
3786             while (ffebld_op (left) == FFEBLD_opCONVERT)
3787               left = ffebld_left (left);
3788             while (ffebld_op (right) == FFEBLD_opCONVERT)
3789               right = ffebld_left (right);
3790
3791             left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
3792             right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
3793
3794             if (left_tree == error_mark_node || left_length == error_mark_node
3795                 || right_tree == error_mark_node
3796                 || right_length == error_mark_node)
3797               return error_mark_node;
3798
3799             if ((ffebld_size_known (left) == 1)
3800                 && (ffebld_size_known (right) == 1))
3801               {
3802                 left_tree
3803                   = ffecom_1 (INDIRECT_REF,
3804                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3805                               left_tree);
3806                 right_tree
3807                   = ffecom_1 (INDIRECT_REF,
3808                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3809                               right_tree);
3810
3811                 item
3812                   = ffecom_2 (code, integer_type_node,
3813                               ffecom_2 (ARRAY_REF,
3814                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3815                                         left_tree,
3816                                         integer_one_node),
3817                               ffecom_2 (ARRAY_REF,
3818                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3819                                         right_tree,
3820                                         integer_one_node));
3821               }
3822             else
3823               {
3824                 item = build_tree_list (NULL_TREE, left_tree);
3825                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, right_tree);
3826                 TREE_CHAIN (TREE_CHAIN (item)) = build_tree_list (NULL_TREE,
3827                                                                left_length);
3828                 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
3829                   = build_tree_list (NULL_TREE, right_length);
3830                 item = ffecom_call_gfrt (FFECOM_gfrtCMP, item, NULL_TREE);
3831                 item = ffecom_2 (code, integer_type_node,
3832                                  item,
3833                                  convert (TREE_TYPE (item),
3834                                           integer_zero_node));
3835               }
3836             item = convert (tree_type, item);
3837           }
3838
3839           return item;
3840
3841         default:
3842           assert ("relational bad basictype" == NULL);
3843           /* Fall through. */
3844         case FFEINFO_basictypeANY:
3845           return error_mark_node;
3846         }
3847       break;
3848
3849     case FFEBLD_opPERCENT_LOC:
3850       item = ffecom_arg_ptr_to_expr (ffebld_left (expr), &list);
3851       return convert (tree_type, item);
3852
3853     case FFEBLD_opITEM:
3854     case FFEBLD_opSTAR:
3855     case FFEBLD_opBOUNDS:
3856     case FFEBLD_opREPEAT:
3857     case FFEBLD_opLABTER:
3858     case FFEBLD_opLABTOK:
3859     case FFEBLD_opIMPDO:
3860     case FFEBLD_opCONCATENATE:
3861     case FFEBLD_opSUBSTR:
3862     default:
3863       assert ("bad op" == NULL);
3864       /* Fall through. */
3865     case FFEBLD_opANY:
3866       return error_mark_node;
3867     }
3868
3869 #if 1
3870   assert ("didn't think anything got here anymore!!" == NULL);
3871 #else
3872   switch (ffebld_arity (expr))
3873     {
3874     case 2:
3875       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3876       TREE_OPERAND (item, 1) = ffecom_expr (ffebld_right (expr));
3877       if (TREE_OPERAND (item, 0) == error_mark_node
3878           || TREE_OPERAND (item, 1) == error_mark_node)
3879         return error_mark_node;
3880       break;
3881
3882     case 1:
3883       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3884       if (TREE_OPERAND (item, 0) == error_mark_node)
3885         return error_mark_node;
3886       break;
3887
3888     default:
3889       break;
3890     }
3891
3892   return fold (item);
3893 #endif
3894 }
3895
3896 #endif
3897 /* Returns the tree that does the intrinsic invocation.
3898
3899    Note: this function applies only to intrinsics returning
3900    CHARACTER*1 or non-CHARACTER results, and to intrinsic
3901    subroutines.  */
3902
3903 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3904 static tree
3905 ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
3906                         ffebld dest, bool *dest_used)
3907 {
3908   tree expr_tree;
3909   tree saved_expr1;             /* For those who need it. */
3910   tree saved_expr2;             /* For those who need it. */
3911   ffeinfoBasictype bt;
3912   ffeinfoKindtype kt;
3913   tree tree_type;
3914   tree arg1_type;
3915   tree real_type;               /* REAL type corresponding to COMPLEX. */
3916   tree tempvar;
3917   ffebld list = ffebld_right (expr);    /* List of (some) args. */
3918   ffebld arg1;                  /* For handy reference. */
3919   ffebld arg2;
3920   ffebld arg3;
3921   ffeintrinImp codegen_imp;
3922   ffecomGfrt gfrt;
3923
3924   assert (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER);
3925
3926   if (dest_used != NULL)
3927     *dest_used = FALSE;
3928
3929   bt = ffeinfo_basictype (ffebld_info (expr));
3930   kt = ffeinfo_kindtype (ffebld_info (expr));
3931   tree_type = ffecom_tree_type[bt][kt];
3932
3933   if (list != NULL)
3934     {
3935       arg1 = ffebld_head (list);
3936       if (arg1 != NULL && ffebld_op (arg1) == FFEBLD_opANY)
3937         return error_mark_node;
3938       if ((list = ffebld_trail (list)) != NULL)
3939         {
3940           arg2 = ffebld_head (list);
3941           if (arg2 != NULL && ffebld_op (arg2) == FFEBLD_opANY)
3942             return error_mark_node;
3943           if ((list = ffebld_trail (list)) != NULL)
3944             {
3945               arg3 = ffebld_head (list);
3946               if (arg3 != NULL && ffebld_op (arg3) == FFEBLD_opANY)
3947                 return error_mark_node;
3948             }
3949           else
3950             arg3 = NULL;
3951         }
3952       else
3953         arg2 = arg3 = NULL;
3954     }
3955   else
3956     arg1 = arg2 = arg3 = NULL;
3957
3958   /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
3959      args.  This is used by the MAX/MIN expansions. */
3960
3961   if (arg1 != NULL)
3962     arg1_type = ffecom_tree_type
3963       [ffeinfo_basictype (ffebld_info (arg1))]
3964       [ffeinfo_kindtype (ffebld_info (arg1))];
3965   else
3966     arg1_type = NULL_TREE;      /* Really not needed, but might catch bugs
3967                                    here. */
3968
3969   /* There are several ways for each of the cases in the following switch
3970      statements to exit (from simplest to use to most complicated):
3971
3972      break;  (when expr_tree == NULL)
3973
3974      A standard call is made to the specific intrinsic just as if it had been
3975      passed in as a dummy procedure and called as any old procedure.  This
3976      method can produce slower code but in some cases it's the easiest way for
3977      now.  However, if a (presumably faster) direct call is available,
3978      that is used, so this is the easiest way in many more cases now.
3979
3980      gfrt = FFECOM_gfrtWHATEVER;
3981      break;
3982
3983      gfrt contains the gfrt index of a library function to call, passing the
3984      argument(s) by value rather than by reference.  Used when a more
3985      careful choice of library function is needed than that provided
3986      by the vanilla `break;'.
3987
3988      return expr_tree;
3989
3990      The expr_tree has been completely set up and is ready to be returned
3991      as is.  No further actions are taken.  Use this when the tree is not
3992      in the simple form for one of the arity_n labels.   */
3993
3994   /* For info on how the switch statement cases were written, see the files
3995      enclosed in comments below the switch statement. */
3996
3997   codegen_imp = ffebld_symter_implementation (ffebld_left (expr));
3998   gfrt = ffeintrin_gfrt_direct (codegen_imp);
3999   if (gfrt == FFECOM_gfrt)
4000     gfrt = ffeintrin_gfrt_indirect (codegen_imp);
4001
4002   switch (codegen_imp)
4003     {
4004     case FFEINTRIN_impABS:
4005     case FFEINTRIN_impCABS:
4006     case FFEINTRIN_impCDABS:
4007     case FFEINTRIN_impDABS:
4008     case FFEINTRIN_impIABS:
4009       if (ffeinfo_basictype (ffebld_info (arg1))
4010           == FFEINFO_basictypeCOMPLEX)
4011         {
4012           if (kt == FFEINFO_kindtypeREAL1)
4013             gfrt = FFECOM_gfrtCABS;
4014           else if (kt == FFEINFO_kindtypeREAL2)
4015             gfrt = FFECOM_gfrtCDABS;
4016           break;
4017         }
4018       return ffecom_1 (ABS_EXPR, tree_type,
4019                        convert (tree_type, ffecom_expr (arg1)));
4020
4021     case FFEINTRIN_impACOS:
4022     case FFEINTRIN_impDACOS:
4023       break;
4024
4025     case FFEINTRIN_impAIMAG:
4026     case FFEINTRIN_impDIMAG:
4027     case FFEINTRIN_impIMAGPART:
4028       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
4029         arg1_type = TREE_TYPE (arg1_type);
4030       else
4031         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
4032
4033       return
4034         convert (tree_type,
4035                  ffecom_1 (IMAGPART_EXPR, arg1_type,
4036                            ffecom_expr (arg1)));
4037
4038     case FFEINTRIN_impAINT:
4039     case FFEINTRIN_impDINT:
4040 #if 0
4041       /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg.  */
4042       return ffecom_1 (FIX_TRUNC_EXPR, tree_type, ffecom_expr (arg1));
4043 #else /* in the meantime, must use floor to avoid range problems with ints */
4044       /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
4045       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4046       return
4047         convert (tree_type,
4048                  ffecom_3 (COND_EXPR, double_type_node,
4049                            ffecom_truth_value
4050                            (ffecom_2 (GE_EXPR, integer_type_node,
4051                                       saved_expr1,
4052                                       convert (arg1_type,
4053                                                ffecom_float_zero_))),
4054                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4055                                              build_tree_list (NULL_TREE,
4056                                                   convert (double_type_node,
4057                                                            saved_expr1)),
4058                                              NULL_TREE),
4059                            ffecom_1 (NEGATE_EXPR, double_type_node,
4060                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4061                                                  build_tree_list (NULL_TREE,
4062                                                   convert (double_type_node,
4063                                                       ffecom_1 (NEGATE_EXPR,
4064                                                                 arg1_type,
4065                                                                saved_expr1))),
4066                                                        NULL_TREE)
4067                                      ))
4068                  );
4069 #endif
4070
4071     case FFEINTRIN_impANINT:
4072     case FFEINTRIN_impDNINT:
4073 #if 0                           /* This way of doing it won't handle real
4074                                    numbers of large magnitudes. */
4075       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4076       expr_tree = convert (tree_type,
4077                            convert (integer_type_node,
4078                                     ffecom_3 (COND_EXPR, tree_type,
4079                                               ffecom_truth_value
4080                                               (ffecom_2 (GE_EXPR,
4081                                                          integer_type_node,
4082                                                          saved_expr1,
4083                                                        ffecom_float_zero_)),
4084                                               ffecom_2 (PLUS_EXPR,
4085                                                         tree_type,
4086                                                         saved_expr1,
4087                                                         ffecom_float_half_),
4088                                               ffecom_2 (MINUS_EXPR,
4089                                                         tree_type,
4090                                                         saved_expr1,
4091                                                      ffecom_float_half_))));
4092       return expr_tree;
4093 #else /* So we instead call floor. */
4094       /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
4095       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4096       return
4097         convert (tree_type,
4098                  ffecom_3 (COND_EXPR, double_type_node,
4099                            ffecom_truth_value
4100                            (ffecom_2 (GE_EXPR, integer_type_node,
4101                                       saved_expr1,
4102                                       convert (arg1_type,
4103                                                ffecom_float_zero_))),
4104                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4105                                              build_tree_list (NULL_TREE,
4106                                                   convert (double_type_node,
4107                                                            ffecom_2 (PLUS_EXPR,
4108                                                                      arg1_type,
4109                                                                      saved_expr1,
4110                                                                      convert (arg1_type,
4111                                                                               ffecom_float_half_)))),
4112                                              NULL_TREE),
4113                            ffecom_1 (NEGATE_EXPR, double_type_node,
4114                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4115                                                        build_tree_list (NULL_TREE,
4116                                                                         convert (double_type_node,
4117                                                                                  ffecom_2 (MINUS_EXPR,
4118                                                                                            arg1_type,
4119                                                                                            convert (arg1_type,
4120                                                                                                     ffecom_float_half_),
4121                                                                                            saved_expr1))),
4122                                                        NULL_TREE))
4123                            )
4124                  );
4125 #endif
4126
4127     case FFEINTRIN_impASIN:
4128     case FFEINTRIN_impDASIN:
4129     case FFEINTRIN_impATAN:
4130     case FFEINTRIN_impDATAN:
4131     case FFEINTRIN_impATAN2:
4132     case FFEINTRIN_impDATAN2:
4133       break;
4134
4135     case FFEINTRIN_impCHAR:
4136     case FFEINTRIN_impACHAR:
4137 #ifdef HOHO
4138       tempvar = ffecom_make_tempvar (char_type_node, 1, -1);
4139 #else
4140       tempvar = ffebld_nonter_hook (expr);
4141       assert (tempvar);
4142 #endif
4143       {
4144         tree tmv = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar)));
4145
4146         expr_tree = ffecom_modify (tmv,
4147                                    ffecom_2 (ARRAY_REF, tmv, tempvar,
4148                                              integer_one_node),
4149                                    convert (tmv, ffecom_expr (arg1)));
4150       }
4151       expr_tree = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar),
4152                             expr_tree,
4153                             tempvar);
4154       expr_tree = ffecom_1 (ADDR_EXPR,
4155                             build_pointer_type (TREE_TYPE (expr_tree)),
4156                             expr_tree);
4157       return expr_tree;
4158
4159     case FFEINTRIN_impCMPLX:
4160     case FFEINTRIN_impDCMPLX:
4161       if (arg2 == NULL)
4162         return
4163           convert (tree_type, ffecom_expr (arg1));
4164
4165       real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4166       return
4167         ffecom_2 (COMPLEX_EXPR, tree_type,
4168                   convert (real_type, ffecom_expr (arg1)),
4169                   convert (real_type,
4170                            ffecom_expr (arg2)));
4171
4172     case FFEINTRIN_impCOMPLEX:
4173       return
4174         ffecom_2 (COMPLEX_EXPR, tree_type,
4175                   ffecom_expr (arg1),
4176                   ffecom_expr (arg2));
4177
4178     case FFEINTRIN_impCONJG:
4179     case FFEINTRIN_impDCONJG:
4180       {
4181         tree arg1_tree;
4182
4183         real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4184         arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4185         return
4186           ffecom_2 (COMPLEX_EXPR, tree_type,
4187                     ffecom_1 (REALPART_EXPR, real_type, arg1_tree),
4188                     ffecom_1 (NEGATE_EXPR, real_type,
4189                               ffecom_1 (IMAGPART_EXPR, real_type, arg1_tree)));
4190       }
4191
4192     case FFEINTRIN_impCOS:
4193     case FFEINTRIN_impCCOS:
4194     case FFEINTRIN_impCDCOS:
4195     case FFEINTRIN_impDCOS:
4196       if (bt == FFEINFO_basictypeCOMPLEX)
4197         {
4198           if (kt == FFEINFO_kindtypeREAL1)
4199             gfrt = FFECOM_gfrtCCOS;     /* Overlapping result okay. */
4200           else if (kt == FFEINFO_kindtypeREAL2)
4201             gfrt = FFECOM_gfrtCDCOS;    /* Overlapping result okay. */
4202         }
4203       break;
4204
4205     case FFEINTRIN_impCOSH:
4206     case FFEINTRIN_impDCOSH:
4207       break;
4208
4209     case FFEINTRIN_impDBLE:
4210     case FFEINTRIN_impDFLOAT:
4211     case FFEINTRIN_impDREAL:
4212     case FFEINTRIN_impFLOAT:
4213     case FFEINTRIN_impIDINT:
4214     case FFEINTRIN_impIFIX:
4215     case FFEINTRIN_impINT2:
4216     case FFEINTRIN_impINT8:
4217     case FFEINTRIN_impINT:
4218     case FFEINTRIN_impLONG:
4219     case FFEINTRIN_impREAL:
4220     case FFEINTRIN_impSHORT:
4221     case FFEINTRIN_impSNGL:
4222       return convert (tree_type, ffecom_expr (arg1));
4223
4224     case FFEINTRIN_impDIM:
4225     case FFEINTRIN_impDDIM:
4226     case FFEINTRIN_impIDIM:
4227       saved_expr1 = ffecom_save_tree (convert (tree_type,
4228                                                ffecom_expr (arg1)));
4229       saved_expr2 = ffecom_save_tree (convert (tree_type,
4230                                                ffecom_expr (arg2)));
4231       return
4232         ffecom_3 (COND_EXPR, tree_type,
4233                   ffecom_truth_value
4234                   (ffecom_2 (GT_EXPR, integer_type_node,
4235                              saved_expr1,
4236                              saved_expr2)),
4237                   ffecom_2 (MINUS_EXPR, tree_type,
4238                             saved_expr1,
4239                             saved_expr2),
4240                   convert (tree_type, ffecom_float_zero_));
4241
4242     case FFEINTRIN_impDPROD:
4243       return
4244         ffecom_2 (MULT_EXPR, tree_type,
4245                   convert (tree_type, ffecom_expr (arg1)),
4246                   convert (tree_type, ffecom_expr (arg2)));
4247
4248     case FFEINTRIN_impEXP:
4249     case FFEINTRIN_impCDEXP:
4250     case FFEINTRIN_impCEXP:
4251     case FFEINTRIN_impDEXP:
4252       if (bt == FFEINFO_basictypeCOMPLEX)
4253         {
4254           if (kt == FFEINFO_kindtypeREAL1)
4255             gfrt = FFECOM_gfrtCEXP;     /* Overlapping result okay. */
4256           else if (kt == FFEINFO_kindtypeREAL2)
4257             gfrt = FFECOM_gfrtCDEXP;    /* Overlapping result okay. */
4258         }
4259       break;
4260
4261     case FFEINTRIN_impICHAR:
4262     case FFEINTRIN_impIACHAR:
4263 #if 0                           /* The simple approach. */
4264       ffecom_char_args_ (&expr_tree, &saved_expr1 /* Ignored */ , arg1);
4265       expr_tree
4266         = ffecom_1 (INDIRECT_REF,
4267                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4268                     expr_tree);
4269       expr_tree
4270         = ffecom_2 (ARRAY_REF,
4271                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4272                     expr_tree,
4273                     integer_one_node);
4274       return convert (tree_type, expr_tree);
4275 #else /* The more interesting (and more optimal) approach. */
4276       expr_tree = ffecom_intrinsic_ichar_ (tree_type, arg1, &saved_expr1);
4277       expr_tree = ffecom_3 (COND_EXPR, tree_type,
4278                             saved_expr1,
4279                             expr_tree,
4280                             convert (tree_type, integer_zero_node));
4281       return expr_tree;
4282 #endif
4283
4284     case FFEINTRIN_impINDEX:
4285       break;
4286
4287     case FFEINTRIN_impLEN:
4288 #if 0
4289       break;                                    /* The simple approach. */
4290 #else
4291       return ffecom_intrinsic_len_ (arg1);      /* The more optimal approach. */
4292 #endif
4293
4294     case FFEINTRIN_impLGE:
4295     case FFEINTRIN_impLGT:
4296     case FFEINTRIN_impLLE:
4297     case FFEINTRIN_impLLT:
4298       break;
4299
4300     case FFEINTRIN_impLOG:
4301     case FFEINTRIN_impALOG:
4302     case FFEINTRIN_impCDLOG:
4303     case FFEINTRIN_impCLOG:
4304     case FFEINTRIN_impDLOG:
4305       if (bt == FFEINFO_basictypeCOMPLEX)
4306         {
4307           if (kt == FFEINFO_kindtypeREAL1)
4308             gfrt = FFECOM_gfrtCLOG;     /* Overlapping result okay. */
4309           else if (kt == FFEINFO_kindtypeREAL2)
4310             gfrt = FFECOM_gfrtCDLOG;    /* Overlapping result okay. */
4311         }
4312       break;
4313
4314     case FFEINTRIN_impLOG10:
4315     case FFEINTRIN_impALOG10:
4316     case FFEINTRIN_impDLOG10:
4317       if (gfrt != FFECOM_gfrt)
4318         break;  /* Already picked one, stick with it. */
4319
4320       if (kt == FFEINFO_kindtypeREAL1)
4321         gfrt = FFECOM_gfrtALOG10;
4322       else if (kt == FFEINFO_kindtypeREAL2)
4323         gfrt = FFECOM_gfrtDLOG10;
4324       break;
4325
4326     case FFEINTRIN_impMAX:
4327     case FFEINTRIN_impAMAX0:
4328     case FFEINTRIN_impAMAX1:
4329     case FFEINTRIN_impDMAX1:
4330     case FFEINTRIN_impMAX0:
4331     case FFEINTRIN_impMAX1:
4332       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4333         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4334       else
4335         arg1_type = tree_type;
4336       expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4337                             convert (arg1_type, ffecom_expr (arg1)),
4338                             convert (arg1_type, ffecom_expr (arg2)));
4339       for (; list != NULL; list = ffebld_trail (list))
4340         {
4341           if ((ffebld_head (list) == NULL)
4342               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4343             continue;
4344           expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4345                                 expr_tree,
4346                                 convert (arg1_type,
4347                                          ffecom_expr (ffebld_head (list))));
4348         }
4349       return convert (tree_type, expr_tree);
4350
4351     case FFEINTRIN_impMIN:
4352     case FFEINTRIN_impAMIN0:
4353     case FFEINTRIN_impAMIN1:
4354     case FFEINTRIN_impDMIN1:
4355     case FFEINTRIN_impMIN0:
4356     case FFEINTRIN_impMIN1:
4357       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4358         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4359       else
4360         arg1_type = tree_type;
4361       expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4362                             convert (arg1_type, ffecom_expr (arg1)),
4363                             convert (arg1_type, ffecom_expr (arg2)));
4364       for (; list != NULL; list = ffebld_trail (list))
4365         {
4366           if ((ffebld_head (list) == NULL)
4367               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4368             continue;
4369           expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4370                                 expr_tree,
4371                                 convert (arg1_type,
4372                                          ffecom_expr (ffebld_head (list))));
4373         }
4374       return convert (tree_type, expr_tree);
4375
4376     case FFEINTRIN_impMOD:
4377     case FFEINTRIN_impAMOD:
4378     case FFEINTRIN_impDMOD:
4379       if (bt != FFEINFO_basictypeREAL)
4380         return ffecom_2 (TRUNC_MOD_EXPR, tree_type,
4381                          convert (tree_type, ffecom_expr (arg1)),
4382                          convert (tree_type, ffecom_expr (arg2)));
4383
4384       if (kt == FFEINFO_kindtypeREAL1)
4385         gfrt = FFECOM_gfrtAMOD;
4386       else if (kt == FFEINFO_kindtypeREAL2)
4387         gfrt = FFECOM_gfrtDMOD;
4388       break;
4389
4390     case FFEINTRIN_impNINT:
4391     case FFEINTRIN_impIDNINT:
4392 #if 0
4393       /* ~~Ideally FIX_ROUND_EXPR would be implemented, but it ain't yet.  */
4394       return ffecom_1 (FIX_ROUND_EXPR, tree_type, ffecom_expr (arg1));
4395 #else
4396       /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
4397       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4398       return
4399         convert (ffecom_integer_type_node,
4400                  ffecom_3 (COND_EXPR, arg1_type,
4401                            ffecom_truth_value
4402                            (ffecom_2 (GE_EXPR, integer_type_node,
4403                                       saved_expr1,
4404                                       convert (arg1_type,
4405                                                ffecom_float_zero_))),
4406                            ffecom_2 (PLUS_EXPR, arg1_type,
4407                                      saved_expr1,
4408                                      convert (arg1_type,
4409                                               ffecom_float_half_)),
4410                            ffecom_2 (MINUS_EXPR, arg1_type,
4411                                      saved_expr1,
4412                                      convert (arg1_type,
4413                                               ffecom_float_half_))));
4414 #endif
4415
4416     case FFEINTRIN_impSIGN:
4417     case FFEINTRIN_impDSIGN:
4418     case FFEINTRIN_impISIGN:
4419       {
4420         tree arg2_tree = ffecom_expr (arg2);
4421
4422         saved_expr1
4423           = ffecom_save_tree
4424           (ffecom_1 (ABS_EXPR, tree_type,
4425                      convert (tree_type,
4426                               ffecom_expr (arg1))));
4427         expr_tree
4428           = ffecom_3 (COND_EXPR, tree_type,
4429                       ffecom_truth_value
4430                       (ffecom_2 (GE_EXPR, integer_type_node,
4431                                  arg2_tree,
4432                                  convert (TREE_TYPE (arg2_tree),
4433                                           integer_zero_node))),
4434                       saved_expr1,
4435                       ffecom_1 (NEGATE_EXPR, tree_type, saved_expr1));
4436         /* Make sure SAVE_EXPRs get referenced early enough. */
4437         expr_tree
4438           = ffecom_2 (COMPOUND_EXPR, tree_type,
4439                       convert (void_type_node, saved_expr1),
4440                       expr_tree);
4441       }
4442       return expr_tree;
4443
4444     case FFEINTRIN_impSIN:
4445     case FFEINTRIN_impCDSIN:
4446     case FFEINTRIN_impCSIN:
4447     case FFEINTRIN_impDSIN:
4448       if (bt == FFEINFO_basictypeCOMPLEX)
4449         {
4450           if (kt == FFEINFO_kindtypeREAL1)
4451             gfrt = FFECOM_gfrtCSIN;     /* Overlapping result okay. */
4452           else if (kt == FFEINFO_kindtypeREAL2)
4453             gfrt = FFECOM_gfrtCDSIN;    /* Overlapping result okay. */
4454         }
4455       break;
4456
4457     case FFEINTRIN_impSINH:
4458     case FFEINTRIN_impDSINH:
4459       break;
4460
4461     case FFEINTRIN_impSQRT:
4462     case FFEINTRIN_impCDSQRT:
4463     case FFEINTRIN_impCSQRT:
4464     case FFEINTRIN_impDSQRT:
4465       if (bt == FFEINFO_basictypeCOMPLEX)
4466         {
4467           if (kt == FFEINFO_kindtypeREAL1)
4468             gfrt = FFECOM_gfrtCSQRT;    /* Overlapping result okay. */
4469           else if (kt == FFEINFO_kindtypeREAL2)
4470             gfrt = FFECOM_gfrtCDSQRT;   /* Overlapping result okay. */
4471         }
4472       break;
4473
4474     case FFEINTRIN_impTAN:
4475     case FFEINTRIN_impDTAN:
4476     case FFEINTRIN_impTANH:
4477     case FFEINTRIN_impDTANH:
4478       break;
4479
4480     case FFEINTRIN_impREALPART:
4481       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
4482         arg1_type = TREE_TYPE (arg1_type);
4483       else
4484         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
4485
4486       return
4487         convert (tree_type,
4488                  ffecom_1 (REALPART_EXPR, arg1_type,
4489                            ffecom_expr (arg1)));
4490
4491     case FFEINTRIN_impIAND:
4492     case FFEINTRIN_impAND:
4493       return ffecom_2 (BIT_AND_EXPR, tree_type,
4494                        convert (tree_type,
4495                                 ffecom_expr (arg1)),
4496                        convert (tree_type,
4497                                 ffecom_expr (arg2)));
4498
4499     case FFEINTRIN_impIOR:
4500     case FFEINTRIN_impOR:
4501       return ffecom_2 (BIT_IOR_EXPR, tree_type,
4502                        convert (tree_type,
4503                                 ffecom_expr (arg1)),
4504                        convert (tree_type,
4505                                 ffecom_expr (arg2)));
4506
4507     case FFEINTRIN_impIEOR:
4508     case FFEINTRIN_impXOR:
4509       return ffecom_2 (BIT_XOR_EXPR, tree_type,
4510                        convert (tree_type,
4511                                 ffecom_expr (arg1)),
4512                        convert (tree_type,
4513                                 ffecom_expr (arg2)));
4514
4515     case FFEINTRIN_impLSHIFT:
4516       return ffecom_2 (LSHIFT_EXPR, tree_type,
4517                        ffecom_expr (arg1),
4518                        convert (integer_type_node,
4519                                 ffecom_expr (arg2)));
4520
4521     case FFEINTRIN_impRSHIFT:
4522       return ffecom_2 (RSHIFT_EXPR, tree_type,
4523                        ffecom_expr (arg1),
4524                        convert (integer_type_node,
4525                                 ffecom_expr (arg2)));
4526
4527     case FFEINTRIN_impNOT:
4528       return ffecom_1 (BIT_NOT_EXPR, tree_type, ffecom_expr (arg1));
4529
4530     case FFEINTRIN_impBIT_SIZE:
4531       return convert (tree_type, TYPE_SIZE (arg1_type));
4532
4533     case FFEINTRIN_impBTEST:
4534       {
4535         ffetargetLogical1 true;
4536         ffetargetLogical1 false;
4537         tree true_tree;
4538         tree false_tree;
4539
4540         ffetarget_logical1 (&true, TRUE);
4541         ffetarget_logical1 (&false, FALSE);
4542         if (true == 1)
4543           true_tree = convert (tree_type, integer_one_node);
4544         else
4545           true_tree = convert (tree_type, build_int_2 (true, 0));
4546         if (false == 0)
4547           false_tree = convert (tree_type, integer_zero_node);
4548         else
4549           false_tree = convert (tree_type, build_int_2 (false, 0));
4550
4551         return
4552           ffecom_3 (COND_EXPR, tree_type,
4553                     ffecom_truth_value
4554                     (ffecom_2 (EQ_EXPR, integer_type_node,
4555                                ffecom_2 (BIT_AND_EXPR, arg1_type,
4556                                          ffecom_expr (arg1),
4557                                          ffecom_2 (LSHIFT_EXPR, arg1_type,
4558                                                    convert (arg1_type,
4559                                                           integer_one_node),
4560                                                    convert (integer_type_node,
4561                                                             ffecom_expr (arg2)))),
4562                                convert (arg1_type,
4563                                         integer_zero_node))),
4564                     false_tree,
4565                     true_tree);
4566       }
4567
4568     case FFEINTRIN_impIBCLR:
4569       return
4570         ffecom_2 (BIT_AND_EXPR, tree_type,
4571                   ffecom_expr (arg1),
4572                   ffecom_1 (BIT_NOT_EXPR, tree_type,
4573                             ffecom_2 (LSHIFT_EXPR, tree_type,
4574                                       convert (tree_type,
4575                                                integer_one_node),
4576                                       convert (integer_type_node,
4577                                                ffecom_expr (arg2)))));
4578
4579     case FFEINTRIN_impIBITS:
4580       {
4581         tree arg3_tree = ffecom_save_tree (convert (integer_type_node,
4582                                                     ffecom_expr (arg3)));
4583         tree uns_type
4584         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4585
4586         expr_tree
4587           = ffecom_2 (BIT_AND_EXPR, tree_type,
4588                       ffecom_2 (RSHIFT_EXPR, tree_type,
4589                                 ffecom_expr (arg1),
4590                                 convert (integer_type_node,
4591                                          ffecom_expr (arg2))),
4592                       convert (tree_type,
4593                                ffecom_2 (RSHIFT_EXPR, uns_type,
4594                                          ffecom_1 (BIT_NOT_EXPR,
4595                                                    uns_type,
4596                                                    convert (uns_type,
4597                                                         integer_zero_node)),
4598                                          ffecom_2 (MINUS_EXPR,
4599                                                    integer_type_node,
4600                                                    TYPE_SIZE (uns_type),
4601                                                    arg3_tree))));
4602 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4603         expr_tree
4604           = ffecom_3 (COND_EXPR, tree_type,
4605                       ffecom_truth_value
4606                       (ffecom_2 (NE_EXPR, integer_type_node,
4607                                  arg3_tree,
4608                                  integer_zero_node)),
4609                       expr_tree,
4610                       convert (tree_type, integer_zero_node));
4611 #endif
4612       }
4613       return expr_tree;
4614
4615     case FFEINTRIN_impIBSET:
4616       return
4617         ffecom_2 (BIT_IOR_EXPR, tree_type,
4618                   ffecom_expr (arg1),
4619                   ffecom_2 (LSHIFT_EXPR, tree_type,
4620                             convert (tree_type, integer_one_node),
4621                             convert (integer_type_node,
4622                                      ffecom_expr (arg2))));
4623
4624     case FFEINTRIN_impISHFT:
4625       {
4626         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4627         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4628                                                     ffecom_expr (arg2)));
4629         tree uns_type
4630         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4631
4632         expr_tree
4633           = ffecom_3 (COND_EXPR, tree_type,
4634                       ffecom_truth_value
4635                       (ffecom_2 (GE_EXPR, integer_type_node,
4636                                  arg2_tree,
4637                                  integer_zero_node)),
4638                       ffecom_2 (LSHIFT_EXPR, tree_type,
4639                                 arg1_tree,
4640                                 arg2_tree),
4641                       convert (tree_type,
4642                                ffecom_2 (RSHIFT_EXPR, uns_type,
4643                                          convert (uns_type, arg1_tree),
4644                                          ffecom_1 (NEGATE_EXPR,
4645                                                    integer_type_node,
4646                                                    arg2_tree))));
4647 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4648         expr_tree
4649           = ffecom_3 (COND_EXPR, tree_type,
4650                       ffecom_truth_value
4651                       (ffecom_2 (NE_EXPR, integer_type_node,
4652                                  arg2_tree,
4653                                  TYPE_SIZE (uns_type))),
4654                       expr_tree,
4655                       convert (tree_type, integer_zero_node));
4656 #endif
4657         /* Make sure SAVE_EXPRs get referenced early enough. */
4658         expr_tree
4659           = ffecom_2 (COMPOUND_EXPR, tree_type,
4660                       convert (void_type_node, arg1_tree),
4661                       ffecom_2 (COMPOUND_EXPR, tree_type,
4662                                 convert (void_type_node, arg2_tree),
4663                                 expr_tree));
4664       }
4665       return expr_tree;
4666
4667     case FFEINTRIN_impISHFTC:
4668       {
4669         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4670         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4671                                                     ffecom_expr (arg2)));
4672         tree arg3_tree = (arg3 == NULL) ? TYPE_SIZE (tree_type)
4673         : ffecom_save_tree (convert (integer_type_node, ffecom_expr (arg3)));
4674         tree shift_neg;
4675         tree shift_pos;
4676         tree mask_arg1;
4677         tree masked_arg1;
4678         tree uns_type
4679         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4680
4681         mask_arg1
4682           = ffecom_2 (LSHIFT_EXPR, tree_type,
4683                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4684                                 convert (tree_type, integer_zero_node)),
4685                       arg3_tree);
4686 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4687         mask_arg1
4688           = ffecom_3 (COND_EXPR, tree_type,
4689                       ffecom_truth_value
4690                       (ffecom_2 (NE_EXPR, integer_type_node,
4691                                  arg3_tree,
4692                                  TYPE_SIZE (uns_type))),
4693                       mask_arg1,
4694                       convert (tree_type, integer_zero_node));
4695 #endif
4696         mask_arg1 = ffecom_save_tree (mask_arg1);
4697         masked_arg1
4698           = ffecom_2 (BIT_AND_EXPR, tree_type,
4699                       arg1_tree,
4700                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4701                                 mask_arg1));
4702         masked_arg1 = ffecom_save_tree (masked_arg1);
4703         shift_neg
4704           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4705                       convert (tree_type,
4706                                ffecom_2 (RSHIFT_EXPR, uns_type,
4707                                          convert (uns_type, masked_arg1),
4708                                          ffecom_1 (NEGATE_EXPR,
4709                                                    integer_type_node,
4710                                                    arg2_tree))),
4711                       ffecom_2 (LSHIFT_EXPR, tree_type,
4712                                 arg1_tree,
4713                                 ffecom_2 (PLUS_EXPR, integer_type_node,
4714                                           arg2_tree,
4715                                           arg3_tree)));
4716         shift_pos
4717           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4718                       ffecom_2 (LSHIFT_EXPR, tree_type,
4719                                 arg1_tree,
4720                                 arg2_tree),
4721                       convert (tree_type,
4722                                ffecom_2 (RSHIFT_EXPR, uns_type,
4723                                          convert (uns_type, masked_arg1),
4724                                          ffecom_2 (MINUS_EXPR,
4725                                                    integer_type_node,
4726                                                    arg3_tree,
4727                                                    arg2_tree))));
4728         expr_tree
4729           = ffecom_3 (COND_EXPR, tree_type,
4730                       ffecom_truth_value
4731                       (ffecom_2 (LT_EXPR, integer_type_node,
4732                                  arg2_tree,
4733                                  integer_zero_node)),
4734                       shift_neg,
4735                       shift_pos);
4736         expr_tree
4737           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4738                       ffecom_2 (BIT_AND_EXPR, tree_type,
4739                                 mask_arg1,
4740                                 arg1_tree),
4741                       ffecom_2 (BIT_AND_EXPR, tree_type,
4742                                 ffecom_1 (BIT_NOT_EXPR, tree_type,
4743                                           mask_arg1),
4744                                 expr_tree));
4745         expr_tree
4746           = ffecom_3 (COND_EXPR, tree_type,
4747                       ffecom_truth_value
4748                       (ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
4749                                  ffecom_2 (EQ_EXPR, integer_type_node,
4750                                            ffecom_1 (ABS_EXPR,
4751                                                      integer_type_node,
4752                                                      arg2_tree),
4753                                            arg3_tree),
4754                                  ffecom_2 (EQ_EXPR, integer_type_node,
4755                                            arg2_tree,
4756                                            integer_zero_node))),
4757                       arg1_tree,
4758                       expr_tree);
4759         /* Make sure SAVE_EXPRs get referenced early enough. */
4760         expr_tree
4761           = ffecom_2 (COMPOUND_EXPR, tree_type,
4762                       convert (void_type_node, arg1_tree),
4763                       ffecom_2 (COMPOUND_EXPR, tree_type,
4764                                 convert (void_type_node, arg2_tree),
4765                                 ffecom_2 (COMPOUND_EXPR, tree_type,
4766                                           convert (void_type_node,
4767                                                    mask_arg1),
4768                                           ffecom_2 (COMPOUND_EXPR, tree_type,
4769                                                     convert (void_type_node,
4770                                                              masked_arg1),
4771                                                     expr_tree))));
4772         expr_tree
4773           = ffecom_2 (COMPOUND_EXPR, tree_type,
4774                       convert (void_type_node,
4775                                arg3_tree),
4776                       expr_tree);
4777       }
4778       return expr_tree;
4779
4780     case FFEINTRIN_impLOC:
4781       {
4782         tree arg1_tree = ffecom_expr (arg1);
4783
4784         expr_tree
4785           = convert (tree_type,
4786                      ffecom_1 (ADDR_EXPR,
4787                                build_pointer_type (TREE_TYPE (arg1_tree)),
4788                                arg1_tree));
4789       }
4790       return expr_tree;
4791
4792     case FFEINTRIN_impMVBITS:
4793       {
4794         tree arg1_tree;
4795         tree arg2_tree;
4796         tree arg3_tree;
4797         ffebld arg4 = ffebld_head (ffebld_trail (list));
4798         tree arg4_tree;
4799         tree arg4_type;
4800         ffebld arg5 = ffebld_head (ffebld_trail (ffebld_trail (list)));
4801         tree arg5_tree;
4802         tree prep_arg1;
4803         tree prep_arg4;
4804         tree arg5_plus_arg3;
4805
4806         arg2_tree = convert (integer_type_node,
4807                              ffecom_expr (arg2));
4808         arg3_tree = ffecom_save_tree (convert (integer_type_node,
4809                                                ffecom_expr (arg3)));
4810         arg4_tree = ffecom_expr_rw (NULL_TREE, arg4);
4811         arg4_type = TREE_TYPE (arg4_tree);
4812
4813         arg1_tree = ffecom_save_tree (convert (arg4_type,
4814                                                ffecom_expr (arg1)));
4815
4816         arg5_tree = ffecom_save_tree (convert (integer_type_node,
4817                                                ffecom_expr (arg5)));
4818
4819         prep_arg1
4820           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4821                       ffecom_2 (BIT_AND_EXPR, arg4_type,
4822                                 ffecom_2 (RSHIFT_EXPR, arg4_type,
4823                                           arg1_tree,
4824                                           arg2_tree),
4825                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4826                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4827                                                     ffecom_1 (BIT_NOT_EXPR,
4828                                                               arg4_type,
4829                                                               convert
4830                                                               (arg4_type,
4831                                                         integer_zero_node)),
4832                                                     arg3_tree))),
4833                       arg5_tree);
4834         arg5_plus_arg3
4835           = ffecom_save_tree (ffecom_2 (PLUS_EXPR, arg4_type,
4836                                         arg5_tree,
4837                                         arg3_tree));
4838         prep_arg4
4839           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4840                       ffecom_1 (BIT_NOT_EXPR, arg4_type,
4841                                 convert (arg4_type,
4842                                          integer_zero_node)),
4843                       arg5_plus_arg3);
4844 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4845         prep_arg4
4846           = ffecom_3 (COND_EXPR, arg4_type,
4847                       ffecom_truth_value
4848                       (ffecom_2 (NE_EXPR, integer_type_node,
4849                                  arg5_plus_arg3,
4850                                  convert (TREE_TYPE (arg5_plus_arg3),
4851                                           TYPE_SIZE (arg4_type)))),
4852                       prep_arg4,
4853                       convert (arg4_type, integer_zero_node));
4854 #endif
4855         prep_arg4
4856           = ffecom_2 (BIT_AND_EXPR, arg4_type,
4857                       arg4_tree,
4858                       ffecom_2 (BIT_IOR_EXPR, arg4_type,
4859                                 prep_arg4,
4860                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4861                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4862                                                     ffecom_1 (BIT_NOT_EXPR,
4863                                                               arg4_type,
4864                                                               convert
4865                                                               (arg4_type,
4866                                                         integer_zero_node)),
4867                                                     arg5_tree))));
4868         prep_arg1
4869           = ffecom_2 (BIT_IOR_EXPR, arg4_type,
4870                       prep_arg1,
4871                       prep_arg4);
4872 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4873         prep_arg1
4874           = ffecom_3 (COND_EXPR, arg4_type,
4875                       ffecom_truth_value
4876                       (ffecom_2 (NE_EXPR, integer_type_node,
4877                                  arg3_tree,
4878                                  convert (TREE_TYPE (arg3_tree),
4879                                           integer_zero_node))),
4880                       prep_arg1,
4881                       arg4_tree);
4882         prep_arg1
4883           = ffecom_3 (COND_EXPR, arg4_type,
4884                       ffecom_truth_value
4885                       (ffecom_2 (NE_EXPR, integer_type_node,
4886                                  arg3_tree,
4887                                  convert (TREE_TYPE (arg3_tree),
4888                                           TYPE_SIZE (arg4_type)))),
4889                       prep_arg1,
4890                       arg1_tree);
4891 #endif
4892         expr_tree
4893           = ffecom_2s (MODIFY_EXPR, void_type_node,
4894                        arg4_tree,
4895                        prep_arg1);
4896         /* Make sure SAVE_EXPRs get referenced early enough. */
4897         expr_tree
4898           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4899                       arg1_tree,
4900                       ffecom_2 (COMPOUND_EXPR, void_type_node,
4901                                 arg3_tree,
4902                                 ffecom_2 (COMPOUND_EXPR, void_type_node,
4903                                           arg5_tree,
4904                                           ffecom_2 (COMPOUND_EXPR, void_type_node,
4905                                                     arg5_plus_arg3,
4906                                                     expr_tree))));
4907         expr_tree
4908           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4909                       arg4_tree,
4910                       expr_tree);
4911
4912       }
4913       return expr_tree;
4914
4915     case FFEINTRIN_impDERF:
4916     case FFEINTRIN_impERF:
4917     case FFEINTRIN_impDERFC:
4918     case FFEINTRIN_impERFC:
4919       break;
4920
4921     case FFEINTRIN_impIARGC:
4922       /* extern int xargc; i__1 = xargc - 1; */
4923       expr_tree = ffecom_2 (MINUS_EXPR, TREE_TYPE (ffecom_tree_xargc_),
4924                             ffecom_tree_xargc_,
4925                             convert (TREE_TYPE (ffecom_tree_xargc_),
4926                                      integer_one_node));
4927       return expr_tree;
4928
4929     case FFEINTRIN_impSIGNAL_func:
4930     case FFEINTRIN_impSIGNAL_subr:
4931       {
4932         tree arg1_tree;
4933         tree arg2_tree;
4934         tree arg3_tree;
4935
4936         arg1_tree = convert (ffecom_f2c_integer_type_node,
4937                              ffecom_expr (arg1));
4938         arg1_tree = ffecom_1 (ADDR_EXPR,
4939                               build_pointer_type (TREE_TYPE (arg1_tree)),
4940                               arg1_tree);
4941
4942         /* Pass procedure as a pointer to it, anything else by value.  */
4943         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4944           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4945         else
4946           arg2_tree = ffecom_ptr_to_expr (arg2);
4947         arg2_tree = convert (TREE_TYPE (null_pointer_node),
4948                              arg2_tree);
4949
4950         if (arg3 != NULL)
4951           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4952         else
4953           arg3_tree = NULL_TREE;
4954
4955         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4956         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4957         TREE_CHAIN (arg1_tree) = arg2_tree;
4958
4959         expr_tree
4960           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4961                           ffecom_gfrt_kindtype (gfrt),
4962                           FALSE,
4963                           ((codegen_imp == FFEINTRIN_impSIGNAL_subr) ?
4964                            NULL_TREE :
4965                            tree_type),
4966                           arg1_tree,
4967                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4968                           ffebld_nonter_hook (expr));
4969
4970         if (arg3_tree != NULL_TREE)
4971           expr_tree
4972             = ffecom_modify (NULL_TREE, arg3_tree,
4973                              convert (TREE_TYPE (arg3_tree),
4974                                       expr_tree));
4975       }
4976       return expr_tree;
4977
4978     case FFEINTRIN_impALARM:
4979       {
4980         tree arg1_tree;
4981         tree arg2_tree;
4982         tree arg3_tree;
4983
4984         arg1_tree = convert (ffecom_f2c_integer_type_node,
4985                              ffecom_expr (arg1));
4986         arg1_tree = ffecom_1 (ADDR_EXPR,
4987                               build_pointer_type (TREE_TYPE (arg1_tree)),
4988                               arg1_tree);
4989
4990         /* Pass procedure as a pointer to it, anything else by value.  */
4991         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4992           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4993         else
4994           arg2_tree = ffecom_ptr_to_expr (arg2);
4995         arg2_tree = convert (TREE_TYPE (null_pointer_node),
4996                              arg2_tree);
4997
4998         if (arg3 != NULL)
4999           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5000         else
5001           arg3_tree = NULL_TREE;
5002
5003         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5004         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5005         TREE_CHAIN (arg1_tree) = arg2_tree;
5006
5007         expr_tree
5008           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5009                           ffecom_gfrt_kindtype (gfrt),
5010                           FALSE,
5011                           NULL_TREE,
5012                           arg1_tree,
5013                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5014                           ffebld_nonter_hook (expr));
5015
5016         if (arg3_tree != NULL_TREE)
5017           expr_tree
5018             = ffecom_modify (NULL_TREE, arg3_tree,
5019                              convert (TREE_TYPE (arg3_tree),
5020                                       expr_tree));
5021       }
5022       return expr_tree;
5023
5024     case FFEINTRIN_impCHDIR_subr:
5025     case FFEINTRIN_impFDATE_subr:
5026     case FFEINTRIN_impFGET_subr:
5027     case FFEINTRIN_impFPUT_subr:
5028     case FFEINTRIN_impGETCWD_subr:
5029     case FFEINTRIN_impHOSTNM_subr:
5030     case FFEINTRIN_impSYSTEM_subr:
5031     case FFEINTRIN_impUNLINK_subr:
5032       {
5033         tree arg1_len = integer_zero_node;
5034         tree arg1_tree;
5035         tree arg2_tree;
5036
5037         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5038
5039         if (arg2 != NULL)
5040           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
5041         else
5042           arg2_tree = NULL_TREE;
5043
5044         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5045         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5046         TREE_CHAIN (arg1_tree) = arg1_len;
5047
5048         expr_tree
5049           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5050                           ffecom_gfrt_kindtype (gfrt),
5051                           FALSE,
5052                           NULL_TREE,
5053                           arg1_tree,
5054                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5055                           ffebld_nonter_hook (expr));
5056
5057         if (arg2_tree != NULL_TREE)
5058           expr_tree
5059             = ffecom_modify (NULL_TREE, arg2_tree,
5060                              convert (TREE_TYPE (arg2_tree),
5061                                       expr_tree));
5062       }
5063       return expr_tree;
5064
5065     case FFEINTRIN_impEXIT:
5066       if (arg1 != NULL)
5067         break;
5068
5069       expr_tree = build_tree_list (NULL_TREE,
5070                                    ffecom_1 (ADDR_EXPR,
5071                                              build_pointer_type
5072                                              (ffecom_integer_type_node),
5073                                              integer_zero_node));
5074
5075       return
5076         ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5077                       ffecom_gfrt_kindtype (gfrt),
5078                       FALSE,
5079                       void_type_node,
5080                       expr_tree,
5081                       NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5082                       ffebld_nonter_hook (expr));
5083
5084     case FFEINTRIN_impFLUSH:
5085       if (arg1 == NULL)
5086         gfrt = FFECOM_gfrtFLUSH;
5087       else
5088         gfrt = FFECOM_gfrtFLUSH1;
5089       break;
5090
5091     case FFEINTRIN_impCHMOD_subr:
5092     case FFEINTRIN_impLINK_subr:
5093     case FFEINTRIN_impRENAME_subr:
5094     case FFEINTRIN_impSYMLNK_subr:
5095       {
5096         tree arg1_len = integer_zero_node;
5097         tree arg1_tree;
5098         tree arg2_len = integer_zero_node;
5099         tree arg2_tree;
5100         tree arg3_tree;
5101
5102         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5103         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
5104         if (arg3 != NULL)
5105           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5106         else
5107           arg3_tree = NULL_TREE;
5108
5109         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5110         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5111         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5112         arg2_len = build_tree_list (NULL_TREE, arg2_len);
5113         TREE_CHAIN (arg1_tree) = arg2_tree;
5114         TREE_CHAIN (arg2_tree) = arg1_len;
5115         TREE_CHAIN (arg1_len) = arg2_len;
5116         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5117                                   ffecom_gfrt_kindtype (gfrt),
5118                                   FALSE,
5119                                   NULL_TREE,
5120                                   arg1_tree,
5121                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5122                                   ffebld_nonter_hook (expr));
5123         if (arg3_tree != NULL_TREE)
5124           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5125                                      convert (TREE_TYPE (arg3_tree),
5126                                               expr_tree));
5127       }
5128       return expr_tree;
5129
5130     case FFEINTRIN_impLSTAT_subr:
5131     case FFEINTRIN_impSTAT_subr:
5132       {
5133         tree arg1_len = integer_zero_node;
5134         tree arg1_tree;
5135         tree arg2_tree;
5136         tree arg3_tree;
5137
5138         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5139
5140         arg2_tree = ffecom_ptr_to_expr (arg2);
5141
5142         if (arg3 != NULL)
5143           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5144         else
5145           arg3_tree = NULL_TREE;
5146
5147         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5148         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5149         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5150         TREE_CHAIN (arg1_tree) = arg2_tree;
5151         TREE_CHAIN (arg2_tree) = arg1_len;
5152         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5153                                   ffecom_gfrt_kindtype (gfrt),
5154                                   FALSE,
5155                                   NULL_TREE,
5156                                   arg1_tree,
5157                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5158                                   ffebld_nonter_hook (expr));
5159         if (arg3_tree != NULL_TREE)
5160           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5161                                      convert (TREE_TYPE (arg3_tree),
5162                                               expr_tree));
5163       }
5164       return expr_tree;
5165
5166     case FFEINTRIN_impFGETC_subr:
5167     case FFEINTRIN_impFPUTC_subr:
5168       {
5169         tree arg1_tree;
5170         tree arg2_tree;
5171         tree arg2_len = integer_zero_node;
5172         tree arg3_tree;
5173
5174         arg1_tree = convert (ffecom_f2c_integer_type_node,
5175                              ffecom_expr (arg1));
5176         arg1_tree = ffecom_1 (ADDR_EXPR,
5177                               build_pointer_type (TREE_TYPE (arg1_tree)),
5178                               arg1_tree);
5179
5180         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
5181         if (arg3 != NULL)
5182           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5183         else
5184           arg3_tree = NULL_TREE;
5185
5186         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5187         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5188         arg2_len = build_tree_list (NULL_TREE, arg2_len);
5189         TREE_CHAIN (arg1_tree) = arg2_tree;
5190         TREE_CHAIN (arg2_tree) = arg2_len;
5191
5192         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5193                                   ffecom_gfrt_kindtype (gfrt),
5194                                   FALSE,
5195                                   NULL_TREE,
5196                                   arg1_tree,
5197                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5198                                   ffebld_nonter_hook (expr));
5199         if (arg3_tree != NULL_TREE)
5200           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5201                                      convert (TREE_TYPE (arg3_tree),
5202                                               expr_tree));
5203       }
5204       return expr_tree;
5205
5206     case FFEINTRIN_impFSTAT_subr:
5207       {
5208         tree arg1_tree;
5209         tree arg2_tree;
5210         tree arg3_tree;
5211
5212         arg1_tree = convert (ffecom_f2c_integer_type_node,
5213                              ffecom_expr (arg1));
5214         arg1_tree = ffecom_1 (ADDR_EXPR,
5215                               build_pointer_type (TREE_TYPE (arg1_tree)),
5216                               arg1_tree);
5217
5218         arg2_tree = convert (ffecom_f2c_ptr_to_integer_type_node,
5219                              ffecom_ptr_to_expr (arg2));
5220
5221         if (arg3 == NULL)
5222           arg3_tree = NULL_TREE;
5223         else
5224           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5225
5226         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5227         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5228         TREE_CHAIN (arg1_tree) = arg2_tree;
5229         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5230                                   ffecom_gfrt_kindtype (gfrt),
5231                                   FALSE,
5232                                   NULL_TREE,
5233                                   arg1_tree,
5234                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5235                                   ffebld_nonter_hook (expr));
5236         if (arg3_tree != NULL_TREE) {
5237           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5238                                      convert (TREE_TYPE (arg3_tree),
5239                                               expr_tree));
5240         }
5241       }
5242       return expr_tree;
5243
5244     case FFEINTRIN_impKILL_subr:
5245       {
5246         tree arg1_tree;
5247         tree arg2_tree;
5248         tree arg3_tree;
5249
5250         arg1_tree = convert (ffecom_f2c_integer_type_node,
5251                              ffecom_expr (arg1));
5252         arg1_tree = ffecom_1 (ADDR_EXPR,
5253                               build_pointer_type (TREE_TYPE (arg1_tree)),
5254                               arg1_tree);
5255
5256         arg2_tree = convert (ffecom_f2c_integer_type_node,
5257                              ffecom_expr (arg2));
5258         arg2_tree = ffecom_1 (ADDR_EXPR,
5259                               build_pointer_type (TREE_TYPE (arg2_tree)),
5260                               arg2_tree);
5261
5262         if (arg3 == NULL)
5263           arg3_tree = NULL_TREE;
5264         else
5265           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5266
5267         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5268         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5269         TREE_CHAIN (arg1_tree) = arg2_tree;
5270         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5271                                   ffecom_gfrt_kindtype (gfrt),
5272                                   FALSE,
5273                                   NULL_TREE,
5274                                   arg1_tree,
5275                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5276                                   ffebld_nonter_hook (expr));
5277         if (arg3_tree != NULL_TREE) {
5278           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5279                                      convert (TREE_TYPE (arg3_tree),
5280                                               expr_tree));
5281         }
5282       }
5283       return expr_tree;
5284
5285     case FFEINTRIN_impCTIME_subr:
5286     case FFEINTRIN_impTTYNAM_subr:
5287       {
5288         tree arg1_len = integer_zero_node;
5289         tree arg1_tree;
5290         tree arg2_tree;
5291
5292         arg1_tree = ffecom_arg_ptr_to_expr (arg2, &arg1_len);
5293
5294         arg2_tree = convert (((codegen_imp == FFEINTRIN_impCTIME_subr) ?
5295                               ffecom_f2c_longint_type_node :
5296                               ffecom_f2c_integer_type_node),
5297                              ffecom_expr (arg1));
5298         arg2_tree = ffecom_1 (ADDR_EXPR,
5299                               build_pointer_type (TREE_TYPE (arg2_tree)),
5300                               arg2_tree);
5301
5302         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5303         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5304         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5305         TREE_CHAIN (arg1_len) = arg2_tree;
5306         TREE_CHAIN (arg1_tree) = arg1_len;
5307
5308         expr_tree
5309           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5310                           ffecom_gfrt_kindtype (gfrt),
5311                           FALSE,
5312                           NULL_TREE,
5313                           arg1_tree,
5314                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5315                           ffebld_nonter_hook (expr));
5316         TREE_SIDE_EFFECTS (expr_tree) = 1;
5317       }
5318       return expr_tree;
5319
5320     case FFEINTRIN_impIRAND:
5321     case FFEINTRIN_impRAND:
5322       /* Arg defaults to 0 (normal random case) */
5323       {
5324         tree arg1_tree;
5325
5326         if (arg1 == NULL)
5327           arg1_tree = ffecom_integer_zero_node;
5328         else
5329           arg1_tree = ffecom_expr (arg1);
5330         arg1_tree = convert (ffecom_f2c_integer_type_node,
5331                              arg1_tree);
5332         arg1_tree = ffecom_1 (ADDR_EXPR,
5333                               build_pointer_type (TREE_TYPE (arg1_tree)),
5334                               arg1_tree);
5335         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5336
5337         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5338                                   ffecom_gfrt_kindtype (gfrt),
5339                                   FALSE,
5340                                   ((codegen_imp == FFEINTRIN_impIRAND) ?
5341                                    ffecom_f2c_integer_type_node :
5342                                    ffecom_f2c_real_type_node),
5343                                   arg1_tree,
5344                                   dest_tree, dest, dest_used,
5345                                   NULL_TREE, TRUE,
5346                                   ffebld_nonter_hook (expr));
5347       }
5348       return expr_tree;
5349
5350     case FFEINTRIN_impFTELL_subr:
5351     case FFEINTRIN_impUMASK_subr:
5352       {
5353         tree arg1_tree;
5354         tree arg2_tree;
5355
5356         arg1_tree = convert (ffecom_f2c_integer_type_node,
5357                              ffecom_expr (arg1));
5358         arg1_tree = ffecom_1 (ADDR_EXPR,
5359                               build_pointer_type (TREE_TYPE (arg1_tree)),
5360                               arg1_tree);
5361
5362         if (arg2 == NULL)
5363           arg2_tree = NULL_TREE;
5364         else
5365           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
5366
5367         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5368                                   ffecom_gfrt_kindtype (gfrt),
5369                                   FALSE,
5370                                   NULL_TREE,
5371                                   build_tree_list (NULL_TREE, arg1_tree),
5372                                   NULL_TREE, NULL, NULL, NULL_TREE,
5373                                   TRUE,
5374                                   ffebld_nonter_hook (expr));
5375         if (arg2_tree != NULL_TREE) {
5376           expr_tree = ffecom_modify (NULL_TREE, arg2_tree,
5377                                      convert (TREE_TYPE (arg2_tree),
5378                                               expr_tree));
5379         }
5380       }
5381       return expr_tree;
5382
5383     case FFEINTRIN_impCPU_TIME:
5384     case FFEINTRIN_impSECOND_subr:
5385       {
5386         tree arg1_tree;
5387
5388         arg1_tree = ffecom_expr_w (NULL_TREE, arg1);
5389
5390         expr_tree
5391           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5392                           ffecom_gfrt_kindtype (gfrt),
5393                           FALSE,
5394                           NULL_TREE,
5395                           NULL_TREE,
5396                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5397                           ffebld_nonter_hook (expr));
5398
5399         expr_tree
5400           = ffecom_modify (NULL_TREE, arg1_tree,
5401                            convert (TREE_TYPE (arg1_tree),
5402                                     expr_tree));
5403       }
5404       return expr_tree;
5405
5406     case FFEINTRIN_impDTIME_subr:
5407     case FFEINTRIN_impETIME_subr:
5408       {
5409         tree arg1_tree;
5410         tree result_tree;
5411
5412         result_tree = ffecom_expr_w (NULL_TREE, arg2);
5413
5414         arg1_tree = ffecom_ptr_to_expr (arg1);
5415
5416         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5417                                   ffecom_gfrt_kindtype (gfrt),
5418                                   FALSE,
5419                                   NULL_TREE,
5420                                   build_tree_list (NULL_TREE, arg1_tree),
5421                                   NULL_TREE, NULL, NULL, NULL_TREE,
5422                                   TRUE,
5423                                   ffebld_nonter_hook (expr));
5424         expr_tree = ffecom_modify (NULL_TREE, result_tree,
5425                                    convert (TREE_TYPE (result_tree),
5426                                             expr_tree));
5427       }
5428       return expr_tree;
5429
5430       /* Straightforward calls of libf2c routines: */
5431     case FFEINTRIN_impABORT:
5432     case FFEINTRIN_impACCESS:
5433     case FFEINTRIN_impBESJ0:
5434     case FFEINTRIN_impBESJ1:
5435     case FFEINTRIN_impBESJN:
5436     case FFEINTRIN_impBESY0:
5437     case FFEINTRIN_impBESY1:
5438     case FFEINTRIN_impBESYN:
5439     case FFEINTRIN_impCHDIR_func:
5440     case FFEINTRIN_impCHMOD_func:
5441     case FFEINTRIN_impDATE:
5442     case FFEINTRIN_impDATE_AND_TIME:
5443     case FFEINTRIN_impDBESJ0:
5444     case FFEINTRIN_impDBESJ1:
5445     case FFEINTRIN_impDBESJN:
5446     case FFEINTRIN_impDBESY0:
5447     case FFEINTRIN_impDBESY1:
5448     case FFEINTRIN_impDBESYN:
5449     case FFEINTRIN_impDTIME_func:
5450     case FFEINTRIN_impETIME_func:
5451     case FFEINTRIN_impFGETC_func:
5452     case FFEINTRIN_impFGET_func:
5453     case FFEINTRIN_impFNUM:
5454     case FFEINTRIN_impFPUTC_func:
5455     case FFEINTRIN_impFPUT_func:
5456     case FFEINTRIN_impFSEEK:
5457     case FFEINTRIN_impFSTAT_func:
5458     case FFEINTRIN_impFTELL_func:
5459     case FFEINTRIN_impGERROR:
5460     case FFEINTRIN_impGETARG:
5461     case FFEINTRIN_impGETCWD_func:
5462     case FFEINTRIN_impGETENV:
5463     case FFEINTRIN_impGETGID:
5464     case FFEINTRIN_impGETLOG:
5465     case FFEINTRIN_impGETPID:
5466     case FFEINTRIN_impGETUID:
5467     case FFEINTRIN_impGMTIME:
5468     case FFEINTRIN_impHOSTNM_func:
5469     case FFEINTRIN_impIDATE_unix:
5470     case FFEINTRIN_impIDATE_vxt:
5471     case FFEINTRIN_impIERRNO:
5472     case FFEINTRIN_impISATTY:
5473     case FFEINTRIN_impITIME:
5474     case FFEINTRIN_impKILL_func:
5475     case FFEINTRIN_impLINK_func:
5476     case FFEINTRIN_impLNBLNK:
5477     case FFEINTRIN_impLSTAT_func:
5478     case FFEINTRIN_impLTIME:
5479     case FFEINTRIN_impMCLOCK8:
5480     case FFEINTRIN_impMCLOCK:
5481     case FFEINTRIN_impPERROR:
5482     case FFEINTRIN_impRENAME_func:
5483     case FFEINTRIN_impSECNDS:
5484     case FFEINTRIN_impSECOND_func:
5485     case FFEINTRIN_impSLEEP:
5486     case FFEINTRIN_impSRAND:
5487     case FFEINTRIN_impSTAT_func:
5488     case FFEINTRIN_impSYMLNK_func:
5489     case FFEINTRIN_impSYSTEM_CLOCK:
5490     case FFEINTRIN_impSYSTEM_func:
5491     case FFEINTRIN_impTIME8:
5492     case FFEINTRIN_impTIME_unix:
5493     case FFEINTRIN_impTIME_vxt:
5494     case FFEINTRIN_impUMASK_func:
5495     case FFEINTRIN_impUNLINK_func:
5496       break;
5497
5498     case FFEINTRIN_impCTIME_func:       /* CHARACTER functions not handled here. */
5499     case FFEINTRIN_impFDATE_func:       /* CHARACTER functions not handled here. */
5500     case FFEINTRIN_impTTYNAM_func:      /* CHARACTER functions not handled here. */
5501     case FFEINTRIN_impNONE:
5502     case FFEINTRIN_imp:         /* Hush up gcc warning. */
5503       fprintf (stderr, "No %s implementation.\n",
5504                ffeintrin_name_implementation (ffebld_symter_implementation (ffebld_left (expr))));
5505       assert ("unimplemented intrinsic" == NULL);
5506       return error_mark_node;
5507     }
5508
5509   assert (gfrt != FFECOM_gfrt); /* Must have an implementation! */
5510
5511   expr_tree = ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt),
5512                                     ffebld_right (expr));
5513
5514   return ffecom_call_ (ffecom_gfrt_tree_ (gfrt), ffecom_gfrt_kindtype (gfrt),
5515                        (ffe_is_f2c_library () && ffecom_gfrt_complex_[gfrt]),
5516                        tree_type,
5517                        expr_tree, dest_tree, dest, dest_used,
5518                        NULL_TREE, TRUE,
5519                        ffebld_nonter_hook (expr));
5520
5521   /* See bottom of this file for f2c transforms used to determine
5522      many of the above implementations.  The info seems to confuse
5523      Emacs's C mode indentation, which is why it's been moved to
5524      the bottom of this source file.  */
5525 }
5526
5527 #endif
5528 /* For power (exponentiation) where right-hand operand is type INTEGER,
5529    generate in-line code to do it the fast way (which, if the operand
5530    is a constant, might just mean a series of multiplies).  */
5531
5532 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5533 static tree
5534 ffecom_expr_power_integer_ (ffebld expr)
5535 {
5536   tree l = ffecom_expr (ffebld_left (expr));
5537   tree r = ffecom_expr (ffebld_right (expr));
5538   tree ltype = TREE_TYPE (l);
5539   tree rtype = TREE_TYPE (r);
5540   tree result = NULL_TREE;
5541
5542   if (l == error_mark_node
5543       || r == error_mark_node)
5544     return error_mark_node;
5545
5546   if (TREE_CODE (r) == INTEGER_CST)
5547     {
5548       int sgn = tree_int_cst_sgn (r);
5549
5550       if (sgn == 0)
5551         return convert (ltype, integer_one_node);
5552
5553       if ((TREE_CODE (ltype) == INTEGER_TYPE)
5554           && (sgn < 0))
5555         {
5556           /* Reciprocal of integer is either 0, -1, or 1, so after
5557              calculating that (which we leave to the back end to do
5558              or not do optimally), don't bother with any multiplying.  */
5559
5560           result = ffecom_tree_divide_ (ltype,
5561                                         convert (ltype, integer_one_node),
5562                                         l,
5563                                         NULL_TREE, NULL, NULL, NULL_TREE);
5564           r = ffecom_1 (NEGATE_EXPR,
5565                         rtype,
5566                         r);
5567           if ((TREE_INT_CST_LOW (r) & 1) == 0)
5568             result = ffecom_1 (ABS_EXPR, rtype,
5569                                result);
5570         }
5571
5572       /* Generate appropriate series of multiplies, preceded
5573          by divide if the exponent is negative.  */
5574
5575       l = save_expr (l);
5576
5577       if (sgn < 0)
5578         {
5579           l = ffecom_tree_divide_ (ltype,
5580                                    convert (ltype, integer_one_node),
5581                                    l,
5582                                    NULL_TREE, NULL, NULL,
5583                                    ffebld_nonter_hook (expr));
5584           r = ffecom_1 (NEGATE_EXPR, rtype, r);
5585           assert (TREE_CODE (r) == INTEGER_CST);
5586
5587           if (tree_int_cst_sgn (r) < 0)
5588             {                   /* The "most negative" number.  */
5589               r = ffecom_1 (NEGATE_EXPR, rtype,
5590                             ffecom_2 (RSHIFT_EXPR, rtype,
5591                                       r,
5592                                       integer_one_node));
5593               l = save_expr (l);
5594               l = ffecom_2 (MULT_EXPR, ltype,
5595                             l,
5596                             l);
5597             }
5598         }
5599
5600       for (;;)
5601         {
5602           if (TREE_INT_CST_LOW (r) & 1)
5603             {
5604               if (result == NULL_TREE)
5605                 result = l;
5606               else
5607                 result = ffecom_2 (MULT_EXPR, ltype,
5608                                    result,
5609                                    l);
5610             }
5611
5612           r = ffecom_2 (RSHIFT_EXPR, rtype,
5613                         r,
5614                         integer_one_node);
5615           if (integer_zerop (r))
5616             break;
5617           assert (TREE_CODE (r) == INTEGER_CST);
5618
5619           l = save_expr (l);
5620           l = ffecom_2 (MULT_EXPR, ltype,
5621                         l,
5622                         l);
5623         }
5624       return result;
5625     }
5626
5627   /* Though rhs isn't a constant, in-line code cannot be expanded
5628      while transforming dummies
5629      because the back end cannot be easily convinced to generate
5630      stores (MODIFY_EXPR), handle temporaries, and so on before
5631      all the appropriate rtx's have been generated for things like
5632      dummy args referenced in rhs -- which doesn't happen until
5633      store_parm_decls() is called (expand_function_start, I believe,
5634      does the actual rtx-stuffing of PARM_DECLs).
5635
5636      So, in this case, let the caller generate the call to the
5637      run-time-library function to evaluate the power for us.  */
5638
5639   if (ffecom_transform_only_dummies_)
5640     return NULL_TREE;
5641
5642   /* Right-hand operand not a constant, expand in-line code to figure
5643      out how to do the multiplies, &c.
5644
5645      The returned expression is expressed this way in GNU C, where l and
5646      r are the "inputs":
5647
5648      ({ typeof (r) rtmp = r;
5649         typeof (l) ltmp = l;
5650         typeof (l) result;
5651
5652         if (rtmp == 0)
5653           result = 1;
5654         else
5655           {
5656             if ((basetypeof (l) == basetypeof (int))
5657                 && (rtmp < 0))
5658               {
5659                 result = ((typeof (l)) 1) / ltmp;
5660                 if ((ltmp < 0) && (((-rtmp) & 1) == 0))
5661                   result = -result;
5662               }
5663             else
5664               {
5665                 result = 1;
5666                 if ((basetypeof (l) != basetypeof (int))
5667                     && (rtmp < 0))
5668                   {
5669                     ltmp = ((typeof (l)) 1) / ltmp;
5670                     rtmp = -rtmp;
5671                     if (rtmp < 0)
5672                       {
5673                         rtmp = -(rtmp >> 1);
5674                         ltmp *= ltmp;
5675                       }
5676                   }
5677                 for (;;)
5678                   {
5679                     if (rtmp & 1)
5680                       result *= ltmp;
5681                     if ((rtmp >>= 1) == 0)
5682                       break;
5683                     ltmp *= ltmp;
5684                   }
5685               }
5686           }
5687         result;
5688      })
5689
5690      Note that some of the above is compile-time collapsable, such as
5691      the first part of the if statements that checks the base type of
5692      l against int.  The if statements are phrased that way to suggest
5693      an easy way to generate the if/else constructs here, knowing that
5694      the back end should (and probably does) eliminate the resulting
5695      dead code (either the int case or the non-int case), something
5696      it couldn't do without the redundant phrasing, requiring explicit
5697      dead-code elimination here, which would be kind of difficult to
5698      read.  */
5699
5700   {
5701     tree rtmp;
5702     tree ltmp;
5703     tree divide;
5704     tree basetypeof_l_is_int;
5705     tree se;
5706     tree t;
5707
5708     basetypeof_l_is_int
5709       = build_int_2 ((TREE_CODE (ltype) == INTEGER_TYPE), 0);
5710
5711     se = expand_start_stmt_expr ();
5712
5713     ffecom_start_compstmt ();
5714
5715 #ifndef HAHA
5716     rtmp = ffecom_make_tempvar ("power_r", rtype,
5717                                 FFETARGET_charactersizeNONE, -1);
5718     ltmp = ffecom_make_tempvar ("power_l", ltype,
5719                                 FFETARGET_charactersizeNONE, -1);
5720     result = ffecom_make_tempvar ("power_res", ltype,
5721                                   FFETARGET_charactersizeNONE, -1);
5722     if (TREE_CODE (ltype) == COMPLEX_TYPE
5723         || TREE_CODE (ltype) == RECORD_TYPE)
5724       divide = ffecom_make_tempvar ("power_div", ltype,
5725                                     FFETARGET_charactersizeNONE, -1);
5726     else
5727       divide = NULL_TREE;
5728 #else  /* HAHA */
5729     {
5730       tree hook;
5731
5732       hook = ffebld_nonter_hook (expr);
5733       assert (hook);
5734       assert (TREE_CODE (hook) == TREE_VEC);
5735       assert (TREE_VEC_LENGTH (hook) == 4);
5736       rtmp = TREE_VEC_ELT (hook, 0);
5737       ltmp = TREE_VEC_ELT (hook, 1);
5738       result = TREE_VEC_ELT (hook, 2);
5739       divide = TREE_VEC_ELT (hook, 3);
5740       if (TREE_CODE (ltype) == COMPLEX_TYPE
5741           || TREE_CODE (ltype) == RECORD_TYPE)
5742         assert (divide);
5743       else
5744         assert (! divide);
5745     }
5746 #endif  /* HAHA */
5747
5748     expand_expr_stmt (ffecom_modify (void_type_node,
5749                                      rtmp,
5750                                      r));
5751     expand_expr_stmt (ffecom_modify (void_type_node,
5752                                      ltmp,
5753                                      l));
5754     expand_start_cond (ffecom_truth_value
5755                        (ffecom_2 (EQ_EXPR, integer_type_node,
5756                                   rtmp,
5757                                   convert (rtype, integer_zero_node))),
5758                        0);
5759     expand_expr_stmt (ffecom_modify (void_type_node,
5760                                      result,
5761                                      convert (ltype, integer_one_node)));
5762     expand_start_else ();
5763     if (! integer_zerop (basetypeof_l_is_int))
5764       {
5765         expand_start_cond (ffecom_2 (LT_EXPR, integer_type_node,
5766                                      rtmp,
5767                                      convert (rtype,
5768                                               integer_zero_node)),
5769                            0);
5770         expand_expr_stmt (ffecom_modify (void_type_node,
5771                                          result,
5772                                          ffecom_tree_divide_
5773                                          (ltype,
5774                                           convert (ltype, integer_one_node),
5775                                           ltmp,
5776                                           NULL_TREE, NULL, NULL,
5777                                           divide)));
5778         expand_start_cond (ffecom_truth_value
5779                            (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5780                                       ffecom_2 (LT_EXPR, integer_type_node,
5781                                                 ltmp,
5782                                                 convert (ltype,
5783                                                          integer_zero_node)),
5784                                       ffecom_2 (EQ_EXPR, integer_type_node,
5785                                                 ffecom_2 (BIT_AND_EXPR,
5786                                                           rtype,
5787                                                           ffecom_1 (NEGATE_EXPR,
5788                                                                     rtype,
5789                                                                     rtmp),
5790                                                           convert (rtype,
5791                                                                    integer_one_node)),
5792                                                 convert (rtype,
5793                                                          integer_zero_node)))),
5794                            0);
5795         expand_expr_stmt (ffecom_modify (void_type_node,
5796                                          result,
5797                                          ffecom_1 (NEGATE_EXPR,
5798                                                    ltype,
5799                                                    result)));
5800         expand_end_cond ();
5801         expand_start_else ();
5802       }
5803     expand_expr_stmt (ffecom_modify (void_type_node,
5804                                      result,
5805                                      convert (ltype, integer_one_node)));
5806     expand_start_cond (ffecom_truth_value
5807                        (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5808                                   ffecom_truth_value_invert
5809                                   (basetypeof_l_is_int),
5810                                   ffecom_2 (LT_EXPR, integer_type_node,
5811                                             rtmp,
5812                                             convert (rtype,
5813                                                      integer_zero_node)))),
5814                        0);
5815     expand_expr_stmt (ffecom_modify (void_type_node,
5816                                      ltmp,
5817                                      ffecom_tree_divide_
5818                                      (ltype,
5819                                       convert (ltype, integer_one_node),
5820                                       ltmp,
5821                                       NULL_TREE, NULL, NULL,
5822                                       divide)));
5823     expand_expr_stmt (ffecom_modify (void_type_node,
5824                                      rtmp,
5825                                      ffecom_1 (NEGATE_EXPR, rtype,
5826                                                rtmp)));
5827     expand_start_cond (ffecom_truth_value
5828                        (ffecom_2 (LT_EXPR, integer_type_node,
5829                                   rtmp,
5830                                   convert (rtype, integer_zero_node))),
5831                        0);
5832     expand_expr_stmt (ffecom_modify (void_type_node,
5833                                      rtmp,
5834                                      ffecom_1 (NEGATE_EXPR, rtype,
5835                                                ffecom_2 (RSHIFT_EXPR,
5836                                                          rtype,
5837                                                          rtmp,
5838                                                          integer_one_node))));
5839     expand_expr_stmt (ffecom_modify (void_type_node,
5840                                      ltmp,
5841                                      ffecom_2 (MULT_EXPR, ltype,
5842                                                ltmp,
5843                                                ltmp)));
5844     expand_end_cond ();
5845     expand_end_cond ();
5846     expand_start_loop (1);
5847     expand_start_cond (ffecom_truth_value
5848                        (ffecom_2 (BIT_AND_EXPR, rtype,
5849                                   rtmp,
5850                                   convert (rtype, integer_one_node))),
5851                        0);
5852     expand_expr_stmt (ffecom_modify (void_type_node,
5853                                      result,
5854                                      ffecom_2 (MULT_EXPR, ltype,
5855                                                result,
5856                                                ltmp)));
5857     expand_end_cond ();
5858     expand_exit_loop_if_false (NULL,
5859                                ffecom_truth_value
5860                                (ffecom_modify (rtype,
5861                                                rtmp,
5862                                                ffecom_2 (RSHIFT_EXPR,
5863                                                          rtype,
5864                                                          rtmp,
5865                                                          integer_one_node))));
5866     expand_expr_stmt (ffecom_modify (void_type_node,
5867                                      ltmp,
5868                                      ffecom_2 (MULT_EXPR, ltype,
5869                                                ltmp,
5870                                                ltmp)));
5871     expand_end_loop ();
5872     expand_end_cond ();
5873     if (!integer_zerop (basetypeof_l_is_int))
5874       expand_end_cond ();
5875     expand_expr_stmt (result);
5876
5877     t = ffecom_end_compstmt ();
5878
5879     result = expand_end_stmt_expr (se);
5880
5881     /* This code comes from c-parse.in, after its expand_end_stmt_expr.  */
5882
5883     if (TREE_CODE (t) == BLOCK)
5884       {
5885         /* Make a BIND_EXPR for the BLOCK already made.  */
5886         result = build (BIND_EXPR, TREE_TYPE (result),
5887                         NULL_TREE, result, t);
5888         /* Remove the block from the tree at this point.
5889            It gets put back at the proper place
5890            when the BIND_EXPR is expanded.  */
5891         delete_block (t);
5892       }
5893     else
5894       result = t;
5895   }
5896
5897   return result;
5898 }
5899
5900 #endif
5901 /* ffecom_expr_transform_ -- Transform symbols in expr
5902
5903    ffebld expr;  // FFE expression.
5904    ffecom_expr_transform_ (expr);
5905
5906    Recursive descent on expr while transforming any untransformed SYMTERs.  */
5907
5908 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5909 static void
5910 ffecom_expr_transform_ (ffebld expr)
5911 {
5912   tree t;
5913   ffesymbol s;
5914
5915 tail_recurse:                   /* :::::::::::::::::::: */
5916
5917   if (expr == NULL)
5918     return;
5919
5920   switch (ffebld_op (expr))
5921     {
5922     case FFEBLD_opSYMTER:
5923       s = ffebld_symter (expr);
5924       t = ffesymbol_hook (s).decl_tree;
5925       if ((t == NULL_TREE)
5926           && ((ffesymbol_kind (s) != FFEINFO_kindNONE)
5927               || ((ffesymbol_where (s) != FFEINFO_whereNONE)
5928                   && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC))))
5929         {
5930           s = ffecom_sym_transform_ (s);
5931           t = ffesymbol_hook (s).decl_tree;     /* Sfunc expr non-dummy,
5932                                                    DIMENSION expr? */
5933         }
5934       break;                    /* Ok if (t == NULL) here. */
5935
5936     case FFEBLD_opITEM:
5937       ffecom_expr_transform_ (ffebld_head (expr));
5938       expr = ffebld_trail (expr);
5939       goto tail_recurse;        /* :::::::::::::::::::: */
5940
5941     default:
5942       break;
5943     }
5944
5945   switch (ffebld_arity (expr))
5946     {
5947     case 2:
5948       ffecom_expr_transform_ (ffebld_left (expr));
5949       expr = ffebld_right (expr);
5950       goto tail_recurse;        /* :::::::::::::::::::: */
5951
5952     case 1:
5953       expr = ffebld_left (expr);
5954       goto tail_recurse;        /* :::::::::::::::::::: */
5955
5956     default:
5957       break;
5958     }
5959
5960   return;
5961 }
5962
5963 #endif
5964 /* Make a type based on info in live f2c.h file.  */
5965
5966 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5967 static void
5968 ffecom_f2c_make_type_ (tree *type, int tcode, const char *name)
5969 {
5970   switch (tcode)
5971     {
5972     case FFECOM_f2ccodeCHAR:
5973       *type = make_signed_type (CHAR_TYPE_SIZE);
5974       break;
5975
5976     case FFECOM_f2ccodeSHORT:
5977       *type = make_signed_type (SHORT_TYPE_SIZE);
5978       break;
5979
5980     case FFECOM_f2ccodeINT:
5981       *type = make_signed_type (INT_TYPE_SIZE);
5982       break;
5983
5984     case FFECOM_f2ccodeLONG:
5985       *type = make_signed_type (LONG_TYPE_SIZE);
5986       break;
5987
5988     case FFECOM_f2ccodeLONGLONG:
5989       *type = make_signed_type (LONG_LONG_TYPE_SIZE);
5990       break;
5991
5992     case FFECOM_f2ccodeCHARPTR:
5993       *type = build_pointer_type (DEFAULT_SIGNED_CHAR
5994                                   ? signed_char_type_node
5995                                   : unsigned_char_type_node);
5996       break;
5997
5998     case FFECOM_f2ccodeFLOAT:
5999       *type = make_node (REAL_TYPE);
6000       TYPE_PRECISION (*type) = FLOAT_TYPE_SIZE;
6001       layout_type (*type);
6002       break;
6003
6004     case FFECOM_f2ccodeDOUBLE:
6005       *type = make_node (REAL_TYPE);
6006       TYPE_PRECISION (*type) = DOUBLE_TYPE_SIZE;
6007       layout_type (*type);
6008       break;
6009
6010     case FFECOM_f2ccodeLONGDOUBLE:
6011       *type = make_node (REAL_TYPE);
6012       TYPE_PRECISION (*type) = LONG_DOUBLE_TYPE_SIZE;
6013       layout_type (*type);
6014       break;
6015
6016     case FFECOM_f2ccodeTWOREALS:
6017       *type = ffecom_make_complex_type_ (ffecom_f2c_real_type_node);
6018       break;
6019
6020     case FFECOM_f2ccodeTWODOUBLEREALS:
6021       *type = ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node);
6022       break;
6023
6024     default:
6025       assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL);
6026       *type = error_mark_node;
6027       return;
6028     }
6029
6030   pushdecl (build_decl (TYPE_DECL,
6031                         ffecom_get_invented_identifier ("__g77_f2c_%s", name),
6032                         *type));
6033 }
6034
6035 #endif
6036 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6037 /* Set the f2c list-directed-I/O code for whatever (integral) type has the
6038    given size.  */
6039
6040 static void
6041 ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
6042                           int code)
6043 {
6044   int j;
6045   tree t;
6046
6047   for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
6048     if ((t = ffecom_tree_type[bt][j]) != NULL_TREE
6049         && compare_tree_int (TYPE_SIZE (t), size) == 0)
6050       {
6051         assert (code != -1);
6052         ffecom_f2c_typecode_[bt][j] = code;
6053         code = -1;
6054       }
6055 }
6056
6057 #endif
6058 /* Finish up globals after doing all program units in file
6059
6060    Need to handle only uninitialized COMMON areas.  */
6061
6062 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6063 static ffeglobal
6064 ffecom_finish_global_ (ffeglobal global)
6065 {
6066   tree cbtype;
6067   tree cbt;
6068   tree size;
6069
6070   if (ffeglobal_type (global) != FFEGLOBAL_typeCOMMON)
6071       return global;
6072
6073   if (ffeglobal_common_init (global))
6074       return global;
6075
6076   cbt = ffeglobal_hook (global);
6077   if ((cbt == NULL_TREE)
6078       || !ffeglobal_common_have_size (global))
6079     return global;              /* No need to make common, never ref'd. */
6080
6081   suspend_momentary ();
6082
6083   DECL_EXTERNAL (cbt) = 0;
6084
6085   /* Give the array a size now.  */
6086
6087   size = build_int_2 ((ffeglobal_common_size (global)
6088                       + ffeglobal_common_pad (global)) - 1,
6089                       0);
6090
6091   cbtype = TREE_TYPE (cbt);
6092   TYPE_DOMAIN (cbtype) = build_range_type (integer_type_node,
6093                                            integer_zero_node,
6094                                            size);
6095   if (!TREE_TYPE (size))
6096     TREE_TYPE (size) = TYPE_DOMAIN (cbtype);
6097   layout_type (cbtype);
6098
6099   cbt = start_decl (cbt, FALSE);
6100   assert (cbt == ffeglobal_hook (global));
6101
6102   finish_decl (cbt, NULL_TREE, FALSE);
6103
6104   return global;
6105 }
6106
6107 #endif
6108 /* Finish up any untransformed symbols.  */
6109
6110 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6111 static ffesymbol
6112 ffecom_finish_symbol_transform_ (ffesymbol s)
6113 {
6114   if ((s == NULL) || (TREE_CODE (current_function_decl) == ERROR_MARK))
6115     return s;
6116
6117   /* It's easy to know to transform an untransformed symbol, to make sure
6118      we put out debugging info for it.  But COMMON variables, unlike
6119      EQUIVALENCE ones, aren't given declarations in addition to the
6120      tree expressions that specify offsets, because COMMON variables
6121      can be referenced in the outer scope where only dummy arguments
6122      (PARM_DECLs) should really be seen.  To be safe, just don't do any
6123      VAR_DECLs for COMMON variables when we transform them for real
6124      use, and therefore we do all the VAR_DECL creating here.  */
6125
6126   if (ffesymbol_hook (s).decl_tree == NULL_TREE)
6127     {
6128       if (ffesymbol_kind (s) != FFEINFO_kindNONE
6129           || (ffesymbol_where (s) != FFEINFO_whereNONE
6130               && ffesymbol_where (s) != FFEINFO_whereINTRINSIC
6131               && ffesymbol_where (s) != FFEINFO_whereDUMMY))
6132         /* Not transformed, and not CHARACTER*(*), and not a dummy
6133            argument, which can happen only if the entry point names
6134            it "rides in on" are all invalidated for other reasons.  */
6135         s = ffecom_sym_transform_ (s);
6136     }
6137
6138   if ((ffesymbol_where (s) == FFEINFO_whereCOMMON)
6139       && (ffesymbol_hook (s).decl_tree != error_mark_node))
6140     {
6141       int yes = suspend_momentary ();
6142
6143       /* This isn't working, at least for dbxout.  The .s file looks
6144          okay to me (burley), but in gdb 4.9 at least, the variables
6145          appear to reside somewhere outside of the common area, so
6146          it doesn't make sense to mislead anyone by generating the info
6147          on those variables until this is fixed.  NOTE: Same problem
6148          with EQUIVALENCE, sadly...see similar #if later.  */
6149       ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s)),
6150                              ffesymbol_storage (s));
6151
6152       resume_momentary (yes);
6153     }
6154
6155   return s;
6156 }
6157
6158 #endif
6159 /* Append underscore(s) to name before calling get_identifier.  "us"
6160    is nonzero if the name already contains an underscore and thus
6161    needs two underscores appended.  */
6162
6163 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6164 static tree
6165 ffecom_get_appended_identifier_ (char us, const char *name)
6166 {
6167   int i;
6168   char *newname;
6169   tree id;
6170
6171   newname = xmalloc ((i = strlen (name)) + 1
6172                      + ffe_is_underscoring ()
6173                      + us);
6174   memcpy (newname, name, i);
6175   newname[i] = '_';
6176   newname[i + us] = '_';
6177   newname[i + 1 + us] = '\0';
6178   id = get_identifier (newname);
6179
6180   free (newname);
6181
6182   return id;
6183 }
6184
6185 #endif
6186 /* Decide whether to append underscore to name before calling
6187    get_identifier.  */
6188
6189 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6190 static tree
6191 ffecom_get_external_identifier_ (ffesymbol s)
6192 {
6193   char us;
6194   const char *name = ffesymbol_text (s);
6195
6196   /* If name is a built-in name, just return it as is.  */
6197
6198   if (!ffe_is_underscoring ()
6199       || (strcmp (name, FFETARGET_nameBLANK_COMMON) == 0)
6200 #if FFETARGET_isENFORCED_MAIN_NAME
6201       || (strcmp (name, FFETARGET_nameENFORCED_NAME) == 0)
6202 #else
6203       || (strcmp (name, FFETARGET_nameUNNAMED_MAIN) == 0)
6204 #endif
6205       || (strcmp (name, FFETARGET_nameUNNAMED_BLOCK_DATA) == 0))
6206     return get_identifier (name);
6207
6208   us = ffe_is_second_underscore ()
6209     ? (strchr (name, '_') != NULL)
6210       : 0;
6211
6212   return ffecom_get_appended_identifier_ (us, name);
6213 }
6214
6215 #endif
6216 /* Decide whether to append underscore to internal name before calling
6217    get_identifier.
6218
6219    This is for non-external, top-function-context names only.  Transform
6220    identifier so it doesn't conflict with the transformed result
6221    of using a _different_ external name.  E.g. if "CALL FOO" is
6222    transformed into "FOO_();", then the variable in "FOO_ = 3"
6223    must be transformed into something that does not conflict, since
6224    these two things should be independent.
6225
6226    The transformation is as follows.  If the name does not contain
6227    an underscore, there is no possible conflict, so just return.
6228    If the name does contain an underscore, then transform it just
6229    like we transform an external identifier.  */
6230
6231 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6232 static tree
6233 ffecom_get_identifier_ (const char *name)
6234 {
6235   /* If name does not contain an underscore, just return it as is.  */
6236
6237   if (!ffe_is_underscoring ()
6238       || (strchr (name, '_') == NULL))
6239     return get_identifier (name);
6240
6241   return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
6242                                           name);
6243 }
6244
6245 #endif
6246 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
6247
6248    tree t;
6249    ffesymbol s;  // kindFUNCTION, whereIMMEDIATE.
6250    t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
6251          ffesymbol_kindtype(s));
6252
6253    Call after setting up containing function and getting trees for all
6254    other symbols.  */
6255
6256 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6257 static tree
6258 ffecom_gen_sfuncdef_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt)
6259 {
6260   ffebld expr = ffesymbol_sfexpr (s);
6261   tree type;
6262   tree func;
6263   tree result;
6264   bool charfunc = (bt == FFEINFO_basictypeCHARACTER);
6265   static bool recurse = FALSE;
6266   int yes;
6267   int old_lineno = lineno;
6268   const char *old_input_filename = input_filename;
6269
6270   ffecom_nested_entry_ = s;
6271
6272   /* For now, we don't have a handy pointer to where the sfunc is actually
6273      defined, though that should be easy to add to an ffesymbol. (The
6274      token/where info available might well point to the place where the type
6275      of the sfunc is declared, especially if that precedes the place where
6276      the sfunc itself is defined, which is typically the case.)  We should
6277      put out a null pointer rather than point somewhere wrong, but I want to
6278      see how it works at this point.  */
6279
6280   input_filename = ffesymbol_where_filename (s);
6281   lineno = ffesymbol_where_filelinenum (s);
6282
6283   /* Pretransform the expression so any newly discovered things belong to the
6284      outer program unit, not to the statement function. */
6285
6286   ffecom_expr_transform_ (expr);
6287
6288   /* Make sure no recursive invocation of this fn (a specific case of failing
6289      to pretransform an sfunc's expression, i.e. where its expression
6290      references another untransformed sfunc) happens. */
6291
6292   assert (!recurse);
6293   recurse = TRUE;
6294
6295   yes = suspend_momentary ();
6296
6297   push_f_function_context ();
6298
6299   if (charfunc)
6300     type = void_type_node;
6301   else
6302     {
6303       type = ffecom_tree_type[bt][kt];
6304       if (type == NULL_TREE)
6305         type = integer_type_node;       /* _sym_exec_transition reports
6306                                            error. */
6307     }
6308
6309   start_function (ffecom_get_identifier_ (ffesymbol_text (s)),
6310                   build_function_type (type, NULL_TREE),
6311                   1,            /* nested/inline */
6312                   0);           /* TREE_PUBLIC */
6313
6314   /* We don't worry about COMPLEX return values here, because this is
6315      entirely internal to our code, and gcc has the ability to return COMPLEX
6316      directly as a value.  */
6317
6318   yes = suspend_momentary ();
6319
6320   if (charfunc)
6321     {                           /* Prepend arg for where result goes. */
6322       tree type;
6323
6324       type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
6325
6326       result = ffecom_get_invented_identifier ("__g77_%s", "result");
6327
6328       ffecom_char_enhance_arg_ (&type, s);      /* Ignore returned length. */
6329
6330       type = build_pointer_type (type);
6331       result = build_decl (PARM_DECL, result, type);
6332
6333       push_parm_decl (result);
6334     }
6335   else
6336     result = NULL_TREE;         /* Not ref'd if !charfunc. */
6337
6338   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s), TRUE);
6339
6340   resume_momentary (yes);
6341
6342   store_parm_decls (0);
6343
6344   ffecom_start_compstmt ();
6345
6346   if (expr != NULL)
6347     {
6348       if (charfunc)
6349         {
6350           ffetargetCharacterSize sz = ffesymbol_size (s);
6351           tree result_length;
6352
6353           result_length = build_int_2 (sz, 0);
6354           TREE_TYPE (result_length) = ffecom_f2c_ftnlen_type_node;
6355
6356           ffecom_prepare_let_char_ (sz, expr);
6357
6358           ffecom_prepare_end ();
6359
6360           ffecom_let_char_ (result, result_length, sz, expr);
6361           expand_null_return ();
6362         }
6363       else
6364         {
6365           ffecom_prepare_expr (expr);
6366
6367           ffecom_prepare_end ();
6368
6369           expand_return (ffecom_modify (NULL_TREE,
6370                                         DECL_RESULT (current_function_decl),
6371                                         ffecom_expr (expr)));
6372         }
6373
6374       clear_momentary ();
6375     }
6376
6377   ffecom_end_compstmt ();
6378
6379   func = current_function_decl;
6380   finish_function (1);
6381
6382   pop_f_function_context ();
6383
6384   resume_momentary (yes);
6385
6386   recurse = FALSE;
6387
6388   lineno = old_lineno;
6389   input_filename = old_input_filename;
6390
6391   ffecom_nested_entry_ = NULL;
6392
6393   return func;
6394 }
6395
6396 #endif
6397
6398 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6399 static const char *
6400 ffecom_gfrt_args_ (ffecomGfrt ix)
6401 {
6402   return ffecom_gfrt_argstring_[ix];
6403 }
6404
6405 #endif
6406 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6407 static tree
6408 ffecom_gfrt_tree_ (ffecomGfrt ix)
6409 {
6410   if (ffecom_gfrt_[ix] == NULL_TREE)
6411     ffecom_make_gfrt_ (ix);
6412
6413   return ffecom_1 (ADDR_EXPR,
6414                    build_pointer_type (TREE_TYPE (ffecom_gfrt_[ix])),
6415                    ffecom_gfrt_[ix]);
6416 }
6417
6418 #endif
6419 /* Return initialize-to-zero expression for this VAR_DECL.  */
6420
6421 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6422 /* A somewhat evil way to prevent the garbage collector
6423    from collecting 'tree' structures.  */
6424 #define NUM_TRACKED_CHUNK 63
6425 static struct tree_ggc_tracker
6426 {
6427   struct tree_ggc_tracker *next;
6428   tree trees[NUM_TRACKED_CHUNK];
6429 } *tracker_head = NULL;
6430
6431 static void
6432 mark_tracker_head (void *arg)
6433 {
6434   struct tree_ggc_tracker *head;
6435   int i;
6436
6437   for (head = * (struct tree_ggc_tracker **) arg;
6438        head != NULL;
6439        head = head->next)
6440   {
6441     ggc_mark (head);
6442     for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6443       ggc_mark_tree (head->trees[i]);
6444   }
6445 }
6446
6447 void
6448 ffecom_save_tree_forever (tree t)
6449 {
6450   int i;
6451   if (tracker_head != NULL)
6452     for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6453       if (tracker_head->trees[i] == NULL)
6454         {
6455           tracker_head->trees[i] = t;
6456           return;
6457         }
6458
6459   {
6460     /* Need to allocate a new block.  */
6461     struct tree_ggc_tracker *old_head = tracker_head;
6462
6463     tracker_head = ggc_alloc (sizeof (*tracker_head));
6464     tracker_head->next = old_head;
6465     tracker_head->trees[0] = t;
6466     for (i = 1; i < NUM_TRACKED_CHUNK; i++)
6467       tracker_head->trees[i] = NULL;
6468   }
6469 }
6470
6471 static tree
6472 ffecom_init_zero_ (tree decl)
6473 {
6474   tree init;
6475   int incremental = TREE_STATIC (decl);
6476   tree type = TREE_TYPE (decl);
6477
6478   if (incremental)
6479     {
6480       make_decl_rtl (decl, NULL, TREE_PUBLIC (decl) ? 1 : 0);
6481       assemble_variable (decl, TREE_PUBLIC (decl) ? 1 : 0, 0, 1);
6482     }
6483
6484   push_momentary ();
6485
6486   if ((TREE_CODE (type) != ARRAY_TYPE)
6487       && (TREE_CODE (type) != RECORD_TYPE)
6488       && (TREE_CODE (type) != UNION_TYPE)
6489       && !incremental)
6490     init = convert (type, integer_zero_node);
6491   else if (!incremental)
6492     {
6493       int momentary = suspend_momentary ();
6494
6495       init = build (CONSTRUCTOR, type, NULL_TREE, NULL_TREE);
6496       TREE_CONSTANT (init) = 1;
6497       TREE_STATIC (init) = 1;
6498
6499       resume_momentary (momentary);
6500     }
6501   else
6502     {
6503       int momentary = suspend_momentary ();
6504
6505       assemble_zeros (int_size_in_bytes (type));
6506       init = error_mark_node;
6507
6508       resume_momentary (momentary);
6509     }
6510
6511   pop_momentary_nofree ();
6512
6513   return init;
6514 }
6515
6516 #endif
6517 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6518 static tree
6519 ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
6520                          tree *maybe_tree)
6521 {
6522   tree expr_tree;
6523   tree length_tree;
6524
6525   switch (ffebld_op (arg))
6526     {
6527     case FFEBLD_opCONTER:       /* For F90, check 0-length. */
6528       if (ffetarget_length_character1
6529           (ffebld_constant_character1
6530            (ffebld_conter (arg))) == 0)
6531         {
6532           *maybe_tree = integer_zero_node;
6533           return convert (tree_type, integer_zero_node);
6534         }
6535
6536       *maybe_tree = integer_one_node;
6537       expr_tree = build_int_2 (*ffetarget_text_character1
6538                                (ffebld_constant_character1
6539                                 (ffebld_conter (arg))),
6540                                0);
6541       TREE_TYPE (expr_tree) = tree_type;
6542       return expr_tree;
6543
6544     case FFEBLD_opSYMTER:
6545     case FFEBLD_opARRAYREF:
6546     case FFEBLD_opFUNCREF:
6547     case FFEBLD_opSUBSTR:
6548       ffecom_char_args_ (&expr_tree, &length_tree, arg);
6549
6550       if ((expr_tree == error_mark_node)
6551           || (length_tree == error_mark_node))
6552         {
6553           *maybe_tree = error_mark_node;
6554           return error_mark_node;
6555         }
6556
6557       if (integer_zerop (length_tree))
6558         {
6559           *maybe_tree = integer_zero_node;
6560           return convert (tree_type, integer_zero_node);
6561         }
6562
6563       expr_tree
6564         = ffecom_1 (INDIRECT_REF,
6565                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6566                     expr_tree);
6567       expr_tree
6568         = ffecom_2 (ARRAY_REF,
6569                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6570                     expr_tree,
6571                     integer_one_node);
6572       expr_tree = convert (tree_type, expr_tree);
6573
6574       if (TREE_CODE (length_tree) == INTEGER_CST)
6575         *maybe_tree = integer_one_node;
6576       else                      /* Must check length at run time.  */
6577         *maybe_tree
6578           = ffecom_truth_value
6579             (ffecom_2 (GT_EXPR, integer_type_node,
6580                        length_tree,
6581                        ffecom_f2c_ftnlen_zero_node));
6582       return expr_tree;
6583
6584     case FFEBLD_opPAREN:
6585     case FFEBLD_opCONVERT:
6586       if (ffeinfo_size (ffebld_info (arg)) == 0)
6587         {
6588           *maybe_tree = integer_zero_node;
6589           return convert (tree_type, integer_zero_node);
6590         }
6591       return ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6592                                       maybe_tree);
6593
6594     case FFEBLD_opCONCATENATE:
6595       {
6596         tree maybe_left;
6597         tree maybe_right;
6598         tree expr_left;
6599         tree expr_right;
6600
6601         expr_left = ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6602                                              &maybe_left);
6603         expr_right = ffecom_intrinsic_ichar_ (tree_type, ffebld_right (arg),
6604                                               &maybe_right);
6605         *maybe_tree = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
6606                                 maybe_left,
6607                                 maybe_right);
6608         expr_tree = ffecom_3 (COND_EXPR, tree_type,
6609                               maybe_left,
6610                               expr_left,
6611                               expr_right);
6612         return expr_tree;
6613       }
6614
6615     default:
6616       assert ("bad op in ICHAR" == NULL);
6617       return error_mark_node;
6618     }
6619 }
6620
6621 #endif
6622 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
6623
6624    tree length_arg;
6625    ffebld expr;
6626    length_arg = ffecom_intrinsic_len_ (expr);
6627
6628    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
6629    subexpressions by constructing the appropriate tree for the
6630    length-of-character-text argument in a calling sequence.  */
6631
6632 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6633 static tree
6634 ffecom_intrinsic_len_ (ffebld expr)
6635 {
6636   ffetargetCharacter1 val;
6637   tree length;
6638
6639   switch (ffebld_op (expr))
6640     {
6641     case FFEBLD_opCONTER:
6642       val = ffebld_constant_character1 (ffebld_conter (expr));
6643       length = build_int_2 (ffetarget_length_character1 (val), 0);
6644       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6645       break;
6646
6647     case FFEBLD_opSYMTER:
6648       {
6649         ffesymbol s = ffebld_symter (expr);
6650         tree item;
6651
6652         item = ffesymbol_hook (s).decl_tree;
6653         if (item == NULL_TREE)
6654           {
6655             s = ffecom_sym_transform_ (s);
6656             item = ffesymbol_hook (s).decl_tree;
6657           }
6658         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
6659           {
6660             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
6661               length = ffesymbol_hook (s).length_tree;
6662             else
6663               {
6664                 length = build_int_2 (ffesymbol_size (s), 0);
6665                 TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6666               }
6667           }
6668         else if (item == error_mark_node)
6669           length = error_mark_node;
6670         else                    /* FFEINFO_kindFUNCTION: */
6671           length = NULL_TREE;
6672       }
6673       break;
6674
6675     case FFEBLD_opARRAYREF:
6676       length = ffecom_intrinsic_len_ (ffebld_left (expr));
6677       break;
6678
6679     case FFEBLD_opSUBSTR:
6680       {
6681         ffebld start;
6682         ffebld end;
6683         ffebld thing = ffebld_right (expr);
6684         tree start_tree;
6685         tree end_tree;
6686
6687         assert (ffebld_op (thing) == FFEBLD_opITEM);
6688         start = ffebld_head (thing);
6689         thing = ffebld_trail (thing);
6690         assert (ffebld_trail (thing) == NULL);
6691         end = ffebld_head (thing);
6692
6693         length = ffecom_intrinsic_len_ (ffebld_left (expr));
6694
6695         if (length == error_mark_node)
6696           break;
6697
6698         if (start == NULL)
6699           {
6700             if (end == NULL)
6701               ;
6702             else
6703               {
6704                 length = convert (ffecom_f2c_ftnlen_type_node,
6705                                   ffecom_expr (end));
6706               }
6707           }
6708         else
6709           {
6710             start_tree = convert (ffecom_f2c_ftnlen_type_node,
6711                                   ffecom_expr (start));
6712
6713             if (start_tree == error_mark_node)
6714               {
6715                 length = error_mark_node;
6716                 break;
6717               }
6718
6719             if (end == NULL)
6720               {
6721                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6722                                    ffecom_f2c_ftnlen_one_node,
6723                                    ffecom_2 (MINUS_EXPR,
6724                                              ffecom_f2c_ftnlen_type_node,
6725                                              length,
6726                                              start_tree));
6727               }
6728             else
6729               {
6730                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
6731                                     ffecom_expr (end));
6732
6733                 if (end_tree == error_mark_node)
6734                   {
6735                     length = error_mark_node;
6736                     break;
6737                   }
6738
6739                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6740                                    ffecom_f2c_ftnlen_one_node,
6741                                    ffecom_2 (MINUS_EXPR,
6742                                              ffecom_f2c_ftnlen_type_node,
6743                                              end_tree, start_tree));
6744               }
6745           }
6746       }
6747       break;
6748
6749     case FFEBLD_opCONCATENATE:
6750       length
6751         = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6752                     ffecom_intrinsic_len_ (ffebld_left (expr)),
6753                     ffecom_intrinsic_len_ (ffebld_right (expr)));
6754       break;
6755
6756     case FFEBLD_opFUNCREF:
6757     case FFEBLD_opCONVERT:
6758       length = build_int_2 (ffebld_size (expr), 0);
6759       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6760       break;
6761
6762     default:
6763       assert ("bad op for single char arg expr" == NULL);
6764       length = ffecom_f2c_ftnlen_zero_node;
6765       break;
6766     }
6767
6768   assert (length != NULL_TREE);
6769
6770   return length;
6771 }
6772
6773 #endif
6774 /* Handle CHARACTER assignments.
6775
6776    Generates code to do the assignment.  Used by ordinary assignment
6777    statement handler ffecom_let_stmt and by statement-function
6778    handler to generate code for a statement function.  */
6779
6780 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6781 static void
6782 ffecom_let_char_ (tree dest_tree, tree dest_length,
6783                   ffetargetCharacterSize dest_size, ffebld source)
6784 {
6785   ffecomConcatList_ catlist;
6786   tree source_length;
6787   tree source_tree;
6788   tree expr_tree;
6789
6790   if ((dest_tree == error_mark_node)
6791       || (dest_length == error_mark_node))
6792     return;
6793
6794   assert (dest_tree != NULL_TREE);
6795   assert (dest_length != NULL_TREE);
6796
6797   /* Source might be an opCONVERT, which just means it is a different size
6798      than the destination.  Since the underlying implementation here handles
6799      that (directly or via the s_copy or s_cat run-time-library functions),
6800      we don't need the "convenience" of an opCONVERT that tells us to
6801      truncate or blank-pad, particularly since the resulting implementation
6802      would probably be slower than otherwise. */
6803
6804   while (ffebld_op (source) == FFEBLD_opCONVERT)
6805     source = ffebld_left (source);
6806
6807   catlist = ffecom_concat_list_new_ (source, dest_size);
6808   switch (ffecom_concat_list_count_ (catlist))
6809     {
6810     case 0:                     /* Shouldn't happen, but in case it does... */
6811       ffecom_concat_list_kill_ (catlist);
6812       source_tree = null_pointer_node;
6813       source_length = ffecom_f2c_ftnlen_zero_node;
6814       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6815       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6816       TREE_CHAIN (TREE_CHAIN (expr_tree))
6817         = build_tree_list (NULL_TREE, dest_length);
6818       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6819         = build_tree_list (NULL_TREE, source_length);
6820
6821       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6822       TREE_SIDE_EFFECTS (expr_tree) = 1;
6823
6824       expand_expr_stmt (expr_tree);
6825
6826       return;
6827
6828     case 1:                     /* The (fairly) easy case. */
6829       ffecom_char_args_ (&source_tree, &source_length,
6830                          ffecom_concat_list_expr_ (catlist, 0));
6831       ffecom_concat_list_kill_ (catlist);
6832       assert (source_tree != NULL_TREE);
6833       assert (source_length != NULL_TREE);
6834
6835       if ((source_tree == error_mark_node)
6836           || (source_length == error_mark_node))
6837         return;
6838
6839       if (dest_size == 1)
6840         {
6841           dest_tree
6842             = ffecom_1 (INDIRECT_REF,
6843                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6844                                                       (dest_tree))),
6845                         dest_tree);
6846           dest_tree
6847             = ffecom_2 (ARRAY_REF,
6848                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6849                                                       (dest_tree))),
6850                         dest_tree,
6851                         integer_one_node);
6852           source_tree
6853             = ffecom_1 (INDIRECT_REF,
6854                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6855                                                       (source_tree))),
6856                         source_tree);
6857           source_tree
6858             = ffecom_2 (ARRAY_REF,
6859                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6860                                                       (source_tree))),
6861                         source_tree,
6862                         integer_one_node);
6863
6864           expr_tree = ffecom_modify (void_type_node, dest_tree, source_tree);
6865
6866           expand_expr_stmt (expr_tree);
6867
6868           return;
6869         }
6870
6871       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6872       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6873       TREE_CHAIN (TREE_CHAIN (expr_tree))
6874         = build_tree_list (NULL_TREE, dest_length);
6875       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6876         = build_tree_list (NULL_TREE, source_length);
6877
6878       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6879       TREE_SIDE_EFFECTS (expr_tree) = 1;
6880
6881       expand_expr_stmt (expr_tree);
6882
6883       return;
6884
6885     default:                    /* Must actually concatenate things. */
6886       break;
6887     }
6888
6889   /* Heavy-duty concatenation. */
6890
6891   {
6892     int count = ffecom_concat_list_count_ (catlist);
6893     int i;
6894     tree lengths;
6895     tree items;
6896     tree length_array;
6897     tree item_array;
6898     tree citem;
6899     tree clength;
6900
6901 #ifdef HOHO
6902     length_array
6903       = lengths
6904       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
6905                              FFETARGET_charactersizeNONE, count, TRUE);
6906     item_array = items = ffecom_push_tempvar (ffecom_f2c_address_type_node,
6907                                               FFETARGET_charactersizeNONE,
6908                                               count, TRUE);
6909 #else
6910     {
6911       tree hook;
6912
6913       hook = ffebld_nonter_hook (source);
6914       assert (hook);
6915       assert (TREE_CODE (hook) == TREE_VEC);
6916       assert (TREE_VEC_LENGTH (hook) == 2);
6917       length_array = lengths = TREE_VEC_ELT (hook, 0);
6918       item_array = items = TREE_VEC_ELT (hook, 1);
6919     }
6920 #endif
6921
6922     for (i = 0; i < count; ++i)
6923       {
6924         ffecom_char_args_ (&citem, &clength,
6925                            ffecom_concat_list_expr_ (catlist, i));
6926         if ((citem == error_mark_node)
6927             || (clength == error_mark_node))
6928           {
6929             ffecom_concat_list_kill_ (catlist);
6930             return;
6931           }
6932
6933         items
6934           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
6935                       ffecom_modify (void_type_node,
6936                                      ffecom_2 (ARRAY_REF,
6937                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
6938                                                item_array,
6939                                                build_int_2 (i, 0)),
6940                                      citem),
6941                       items);
6942         lengths
6943           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
6944                       ffecom_modify (void_type_node,
6945                                      ffecom_2 (ARRAY_REF,
6946                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
6947                                                length_array,
6948                                                build_int_2 (i, 0)),
6949                                      clength),
6950                       lengths);
6951       }
6952
6953     expr_tree = build_tree_list (NULL_TREE, dest_tree);
6954     TREE_CHAIN (expr_tree)
6955       = build_tree_list (NULL_TREE,
6956                          ffecom_1 (ADDR_EXPR,
6957                                    build_pointer_type (TREE_TYPE (items)),
6958                                    items));
6959     TREE_CHAIN (TREE_CHAIN (expr_tree))
6960       = build_tree_list (NULL_TREE,
6961                          ffecom_1 (ADDR_EXPR,
6962                                    build_pointer_type (TREE_TYPE (lengths)),
6963                                    lengths));
6964     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6965       = build_tree_list
6966         (NULL_TREE,
6967          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
6968                    convert (ffecom_f2c_ftnlen_type_node,
6969                             build_int_2 (count, 0))));
6970     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))))
6971       = build_tree_list (NULL_TREE, dest_length);
6972
6973     expr_tree = ffecom_call_gfrt (FFECOM_gfrtCAT, expr_tree, NULL_TREE);
6974     TREE_SIDE_EFFECTS (expr_tree) = 1;
6975
6976     expand_expr_stmt (expr_tree);
6977   }
6978
6979   ffecom_concat_list_kill_ (catlist);
6980 }
6981
6982 #endif
6983 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
6984
6985    ffecomGfrt ix;
6986    ffecom_make_gfrt_(ix);
6987
6988    Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
6989    for the indicated run-time routine (ix).  */
6990
6991 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6992 static void
6993 ffecom_make_gfrt_ (ffecomGfrt ix)
6994 {
6995   tree t;
6996   tree ttype;
6997
6998   switch (ffecom_gfrt_type_[ix])
6999     {
7000     case FFECOM_rttypeVOID_:
7001       ttype = void_type_node;
7002       break;
7003
7004     case FFECOM_rttypeVOIDSTAR_:
7005       ttype = TREE_TYPE (null_pointer_node);    /* `void *'. */
7006       break;
7007
7008     case FFECOM_rttypeFTNINT_:
7009       ttype = ffecom_f2c_ftnint_type_node;
7010       break;
7011
7012     case FFECOM_rttypeINTEGER_:
7013       ttype = ffecom_f2c_integer_type_node;
7014       break;
7015
7016     case FFECOM_rttypeLONGINT_:
7017       ttype = ffecom_f2c_longint_type_node;
7018       break;
7019
7020     case FFECOM_rttypeLOGICAL_:
7021       ttype = ffecom_f2c_logical_type_node;
7022       break;
7023
7024     case FFECOM_rttypeREAL_F2C_:
7025       ttype = double_type_node;
7026       break;
7027
7028     case FFECOM_rttypeREAL_GNU_:
7029       ttype = float_type_node;
7030       break;
7031
7032     case FFECOM_rttypeCOMPLEX_F2C_:
7033       ttype = void_type_node;
7034       break;
7035
7036     case FFECOM_rttypeCOMPLEX_GNU_:
7037       ttype = ffecom_f2c_complex_type_node;
7038       break;
7039
7040     case FFECOM_rttypeDOUBLE_:
7041       ttype = double_type_node;
7042       break;
7043
7044     case FFECOM_rttypeDOUBLEREAL_:
7045       ttype = ffecom_f2c_doublereal_type_node;
7046       break;
7047
7048     case FFECOM_rttypeDBLCMPLX_F2C_:
7049       ttype = void_type_node;
7050       break;
7051
7052     case FFECOM_rttypeDBLCMPLX_GNU_:
7053       ttype = ffecom_f2c_doublecomplex_type_node;
7054       break;
7055
7056     case FFECOM_rttypeCHARACTER_:
7057       ttype = void_type_node;
7058       break;
7059
7060     default:
7061       ttype = NULL;
7062       assert ("bad rttype" == NULL);
7063       break;
7064     }
7065
7066   ttype = build_function_type (ttype, NULL_TREE);
7067   t = build_decl (FUNCTION_DECL,
7068                   get_identifier (ffecom_gfrt_name_[ix]),
7069                   ttype);
7070   DECL_EXTERNAL (t) = 1;
7071   TREE_PUBLIC (t) = 1;
7072   TREE_THIS_VOLATILE (t) = ffecom_gfrt_volatile_[ix] ? 1 : 0;
7073
7074   t = start_decl (t, TRUE);
7075
7076   finish_decl (t, NULL_TREE, TRUE);
7077
7078   ffecom_gfrt_[ix] = t;
7079 }
7080
7081 #endif
7082 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group.  */
7083
7084 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7085 static void
7086 ffecom_member_phase1_ (ffestorag mst UNUSED, ffestorag st)
7087 {
7088   ffesymbol s = ffestorag_symbol (st);
7089
7090   if (ffesymbol_namelisted (s))
7091     ffecom_member_namelisted_ = TRUE;
7092 }
7093
7094 #endif
7095 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group.  Declare
7096    the member so debugger will see it.  Otherwise nobody should be
7097    referencing the member.  */
7098
7099 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7100 static void
7101 ffecom_member_phase2_ (ffestorag mst, ffestorag st)
7102 {
7103   ffesymbol s;
7104   tree t;
7105   tree mt;
7106   tree type;
7107
7108   if ((mst == NULL)
7109       || ((mt = ffestorag_hook (mst)) == NULL)
7110       || (mt == error_mark_node))
7111     return;
7112
7113   if ((st == NULL)
7114       || ((s = ffestorag_symbol (st)) == NULL))
7115     return;
7116
7117   type = ffecom_type_localvar_ (s,
7118                                 ffesymbol_basictype (s),
7119                                 ffesymbol_kindtype (s));
7120   if (type == error_mark_node)
7121     return;
7122
7123   t = build_decl (VAR_DECL,
7124                   ffecom_get_identifier_ (ffesymbol_text (s)),
7125                   type);
7126
7127   TREE_STATIC (t) = TREE_STATIC (mt);
7128   DECL_INITIAL (t) = NULL_TREE;
7129   TREE_ASM_WRITTEN (t) = 1;
7130
7131   DECL_RTL (t)
7132     = gen_rtx (MEM, TYPE_MODE (type),
7133                plus_constant (XEXP (DECL_RTL (mt), 0),
7134                               ffestorag_modulo (mst)
7135                               + ffestorag_offset (st)
7136                               - ffestorag_offset (mst)));
7137
7138   t = start_decl (t, FALSE);
7139
7140   finish_decl (t, NULL_TREE, FALSE);
7141 }
7142
7143 #endif
7144 /* Prepare source expression for assignment into a destination perhaps known
7145    to be of a specific size.  */
7146
7147 static void
7148 ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size, ffebld source)
7149 {
7150   ffecomConcatList_ catlist;
7151   int count;
7152   int i;
7153   tree ltmp;
7154   tree itmp;
7155   tree tempvar = NULL_TREE;
7156
7157   while (ffebld_op (source) == FFEBLD_opCONVERT)
7158     source = ffebld_left (source);
7159
7160   catlist = ffecom_concat_list_new_ (source, dest_size);
7161   count = ffecom_concat_list_count_ (catlist);
7162
7163   if (count >= 2)
7164     {
7165       ltmp
7166         = ffecom_make_tempvar ("let_char_len", ffecom_f2c_ftnlen_type_node,
7167                                FFETARGET_charactersizeNONE, count);
7168       itmp
7169         = ffecom_make_tempvar ("let_char_item", ffecom_f2c_address_type_node,
7170                                FFETARGET_charactersizeNONE, count);
7171
7172       tempvar = make_tree_vec (2);
7173       TREE_VEC_ELT (tempvar, 0) = ltmp;
7174       TREE_VEC_ELT (tempvar, 1) = itmp;
7175     }
7176
7177   for (i = 0; i < count; ++i)
7178     ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist, i));
7179
7180   ffecom_concat_list_kill_ (catlist);
7181
7182   if (tempvar)
7183     {
7184       ffebld_nonter_set_hook (source, tempvar);
7185       current_binding_level->prep_state = 1;
7186     }
7187 }
7188
7189 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
7190
7191    Ignores STAR (alternate-return) dummies.  All other get exec-transitioned
7192    (which generates their trees) and then their trees get push_parm_decl'd.
7193
7194    The second arg is TRUE if the dummies are for a statement function, in
7195    which case lengths are not pushed for character arguments (since they are
7196    always known by both the caller and the callee, though the code allows
7197    for someday permitting CHAR*(*) stmtfunc dummies).  */
7198
7199 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7200 static void
7201 ffecom_push_dummy_decls_ (ffebld dummy_list, bool stmtfunc)
7202 {
7203   ffebld dummy;
7204   ffebld dumlist;
7205   ffesymbol s;
7206   tree parm;
7207
7208   ffecom_transform_only_dummies_ = TRUE;
7209
7210   /* First push the parms corresponding to actual dummy "contents".  */
7211
7212   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7213     {
7214       dummy = ffebld_head (dumlist);
7215       switch (ffebld_op (dummy))
7216         {
7217         case FFEBLD_opSTAR:
7218         case FFEBLD_opANY:
7219           continue;             /* Forget alternate returns. */
7220
7221         default:
7222           break;
7223         }
7224       assert (ffebld_op (dummy) == FFEBLD_opSYMTER);
7225       s = ffebld_symter (dummy);
7226       parm = ffesymbol_hook (s).decl_tree;
7227       if (parm == NULL_TREE)
7228         {
7229           s = ffecom_sym_transform_ (s);
7230           parm = ffesymbol_hook (s).decl_tree;
7231           assert (parm != NULL_TREE);
7232         }
7233       if (parm != error_mark_node)
7234         push_parm_decl (parm);
7235     }
7236
7237   /* Then, for CHARACTER dummies, push the parms giving their lengths.  */
7238
7239   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7240     {
7241       dummy = ffebld_head (dumlist);
7242       switch (ffebld_op (dummy))
7243         {
7244         case FFEBLD_opSTAR:
7245         case FFEBLD_opANY:
7246           continue;             /* Forget alternate returns, they mean
7247                                    NOTHING! */
7248
7249         default:
7250           break;
7251         }
7252       s = ffebld_symter (dummy);
7253       if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
7254         continue;               /* Only looking for CHARACTER arguments. */
7255       if (stmtfunc && (ffesymbol_size (s) != FFETARGET_charactersizeNONE))
7256         continue;               /* Stmtfunc arg with known size needs no
7257                                    length param. */
7258       if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
7259         continue;               /* Only looking for variables and arrays. */
7260       parm = ffesymbol_hook (s).length_tree;
7261       assert (parm != NULL_TREE);
7262       if (parm != error_mark_node)
7263         push_parm_decl (parm);
7264     }
7265
7266   ffecom_transform_only_dummies_ = FALSE;
7267 }
7268
7269 #endif
7270 /* ffecom_start_progunit_ -- Beginning of program unit
7271
7272    Does GNU back end stuff necessary to teach it about the start of its
7273    equivalent of a Fortran program unit.  */
7274
7275 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7276 static void
7277 ffecom_start_progunit_ ()
7278 {
7279   ffesymbol fn = ffecom_primary_entry_;
7280   ffebld arglist;
7281   tree id;                      /* Identifier (name) of function. */
7282   tree type;                    /* Type of function. */
7283   tree result;                  /* Result of function. */
7284   ffeinfoBasictype bt;
7285   ffeinfoKindtype kt;
7286   ffeglobal g;
7287   ffeglobalType gt;
7288   ffeglobalType egt = FFEGLOBAL_type;
7289   bool charfunc;
7290   bool cmplxfunc;
7291   bool altentries = (ffecom_num_entrypoints_ != 0);
7292   bool multi
7293   = altentries
7294   && (ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
7295   && (ffecom_master_bt_ == FFEINFO_basictypeNONE);
7296   bool main_program = FALSE;
7297   int old_lineno = lineno;
7298   const char *old_input_filename = input_filename;
7299   int yes;
7300
7301   assert (fn != NULL);
7302   assert (ffesymbol_hook (fn).decl_tree == NULL_TREE);
7303
7304   input_filename = ffesymbol_where_filename (fn);
7305   lineno = ffesymbol_where_filelinenum (fn);
7306
7307   /* c-parse.y indeed does call suspend_momentary and not only ignores the
7308      return value, but also never calls resume_momentary, when starting an
7309      outer function (see "fndef:", "setspecs:", and so on).  So g77 does the
7310      same thing.  It shouldn't be a problem since start_function calls
7311      temporary_allocation, but it might be necessary.  If it causes a problem
7312      here, then maybe there's a bug lurking in gcc.  NOTE: This identical
7313      comment appears twice in thist file.  */
7314
7315   suspend_momentary ();
7316
7317   switch (ffecom_primary_entry_kind_)
7318     {
7319     case FFEINFO_kindPROGRAM:
7320       main_program = TRUE;
7321       gt = FFEGLOBAL_typeMAIN;
7322       bt = FFEINFO_basictypeNONE;
7323       kt = FFEINFO_kindtypeNONE;
7324       type = ffecom_tree_fun_type_void;
7325       charfunc = FALSE;
7326       cmplxfunc = FALSE;
7327       break;
7328
7329     case FFEINFO_kindBLOCKDATA:
7330       gt = FFEGLOBAL_typeBDATA;
7331       bt = FFEINFO_basictypeNONE;
7332       kt = FFEINFO_kindtypeNONE;
7333       type = ffecom_tree_fun_type_void;
7334       charfunc = FALSE;
7335       cmplxfunc = FALSE;
7336       break;
7337
7338     case FFEINFO_kindFUNCTION:
7339       gt = FFEGLOBAL_typeFUNC;
7340       egt = FFEGLOBAL_typeEXT;
7341       bt = ffesymbol_basictype (fn);
7342       kt = ffesymbol_kindtype (fn);
7343       if (bt == FFEINFO_basictypeNONE)
7344         {
7345           ffeimplic_establish_symbol (fn);
7346           if (ffesymbol_funcresult (fn) != NULL)
7347             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
7348           bt = ffesymbol_basictype (fn);
7349           kt = ffesymbol_kindtype (fn);
7350         }
7351
7352       if (multi)
7353         charfunc = cmplxfunc = FALSE;
7354       else if (bt == FFEINFO_basictypeCHARACTER)
7355         charfunc = TRUE, cmplxfunc = FALSE;
7356       else if ((bt == FFEINFO_basictypeCOMPLEX)
7357                && ffesymbol_is_f2c (fn)
7358                && !altentries)
7359         charfunc = FALSE, cmplxfunc = TRUE;
7360       else
7361         charfunc = cmplxfunc = FALSE;
7362
7363       if (multi || charfunc)
7364         type = ffecom_tree_fun_type_void;
7365       else if (ffesymbol_is_f2c (fn) && !altentries)
7366         type = ffecom_tree_fun_type[bt][kt];
7367       else
7368         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
7369
7370       if ((type == NULL_TREE)
7371           || (TREE_TYPE (type) == NULL_TREE))
7372         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
7373       break;
7374
7375     case FFEINFO_kindSUBROUTINE:
7376       gt = FFEGLOBAL_typeSUBR;
7377       egt = FFEGLOBAL_typeEXT;
7378       bt = FFEINFO_basictypeNONE;
7379       kt = FFEINFO_kindtypeNONE;
7380       if (ffecom_is_altreturning_)
7381         type = ffecom_tree_subr_type;
7382       else
7383         type = ffecom_tree_fun_type_void;
7384       charfunc = FALSE;
7385       cmplxfunc = FALSE;
7386       break;
7387
7388     default:
7389       assert ("say what??" == NULL);
7390       /* Fall through. */
7391     case FFEINFO_kindANY:
7392       gt = FFEGLOBAL_typeANY;
7393       bt = FFEINFO_basictypeNONE;
7394       kt = FFEINFO_kindtypeNONE;
7395       type = error_mark_node;
7396       charfunc = FALSE;
7397       cmplxfunc = FALSE;
7398       break;
7399     }
7400
7401   if (altentries)
7402     {
7403       id = ffecom_get_invented_identifier ("__g77_masterfun_%s",
7404                                            ffesymbol_text (fn));
7405     }
7406 #if FFETARGET_isENFORCED_MAIN
7407   else if (main_program)
7408     id = get_identifier (FFETARGET_nameENFORCED_MAIN_NAME);
7409 #endif
7410   else
7411     id = ffecom_get_external_identifier_ (fn);
7412
7413   start_function (id,
7414                   type,
7415                   0,            /* nested/inline */
7416                   !altentries); /* TREE_PUBLIC */
7417
7418   TREE_USED (current_function_decl) = 1;        /* Avoid spurious warning if altentries. */
7419
7420   if (!altentries
7421       && ((g = ffesymbol_global (fn)) != NULL)
7422       && ((ffeglobal_type (g) == gt)
7423           || (ffeglobal_type (g) == egt)))
7424     {
7425       ffeglobal_set_hook (g, current_function_decl);
7426     }
7427
7428   yes = suspend_momentary ();
7429
7430   /* Arg handling needs exec-transitioned ffesymbols to work with.  But
7431      exec-transitioning needs current_function_decl to be filled in.  So we
7432      do these things in two phases. */
7433
7434   if (altentries)
7435     {                           /* 1st arg identifies which entrypoint. */
7436       ffecom_which_entrypoint_decl_
7437         = build_decl (PARM_DECL,
7438                       ffecom_get_invented_identifier ("__g77_%s",
7439                                                       "which_entrypoint"),
7440                       integer_type_node);
7441       push_parm_decl (ffecom_which_entrypoint_decl_);
7442     }
7443
7444   if (charfunc
7445       || cmplxfunc
7446       || multi)
7447     {                           /* Arg for result (return value). */
7448       tree type;
7449       tree length;
7450
7451       if (charfunc)
7452         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
7453       else if (cmplxfunc)
7454         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
7455       else
7456         type = ffecom_multi_type_node_;
7457
7458       result = ffecom_get_invented_identifier ("__g77_%s", "result");
7459
7460       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
7461
7462       if (charfunc)
7463         length = ffecom_char_enhance_arg_ (&type, fn);
7464       else
7465         length = NULL_TREE;     /* Not ref'd if !charfunc. */
7466
7467       type = build_pointer_type (type);
7468       result = build_decl (PARM_DECL, result, type);
7469
7470       push_parm_decl (result);
7471       if (multi)
7472         ffecom_multi_retval_ = result;
7473       else
7474         ffecom_func_result_ = result;
7475
7476       if (charfunc)
7477         {
7478           push_parm_decl (length);
7479           ffecom_func_length_ = length;
7480         }
7481     }
7482
7483   if (ffecom_primary_entry_is_proc_)
7484     {
7485       if (altentries)
7486         arglist = ffecom_master_arglist_;
7487       else
7488         arglist = ffesymbol_dummyargs (fn);
7489       ffecom_push_dummy_decls_ (arglist, FALSE);
7490     }
7491
7492   resume_momentary (yes);
7493
7494   if (TREE_CODE (current_function_decl) != ERROR_MARK)
7495     store_parm_decls (main_program ? 1 : 0);
7496
7497   ffecom_start_compstmt ();
7498   /* Disallow temp vars at this level.  */
7499   current_binding_level->prep_state = 2;
7500
7501   lineno = old_lineno;
7502   input_filename = old_input_filename;
7503
7504   /* This handles any symbols still untransformed, in case -g specified.
7505      This used to be done in ffecom_finish_progunit, but it turns out to
7506      be necessary to do it here so that statement functions are
7507      expanded before code.  But don't bother for BLOCK DATA.  */
7508
7509   if (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
7510     ffesymbol_drive (ffecom_finish_symbol_transform_);
7511 }
7512
7513 #endif
7514 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
7515
7516    ffesymbol s;
7517    ffecom_sym_transform_(s);
7518
7519    The ffesymbol_hook info for s is updated with appropriate backend info
7520    on the symbol.  */
7521
7522 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7523 static ffesymbol
7524 ffecom_sym_transform_ (ffesymbol s)
7525 {
7526   tree t;                       /* Transformed thingy. */
7527   tree tlen;                    /* Length if CHAR*(*). */
7528   bool addr;                    /* Is t the address of the thingy? */
7529   ffeinfoBasictype bt;
7530   ffeinfoKindtype kt;
7531   ffeglobal g;
7532   int yes;
7533   int old_lineno = lineno;
7534   const char *old_input_filename = input_filename;
7535
7536   /* Must ensure special ASSIGN variables are declared at top of outermost
7537      block, else they'll end up in the innermost block when their first
7538      ASSIGN is seen, which leaves them out of scope when they're the
7539      subject of a GOTO or I/O statement.
7540
7541      We make this variable even if -fugly-assign.  Just let it go unused,
7542      in case it turns out there are cases where we really want to use this
7543      variable anyway (e.g. ASSIGN to INTEGER*2 variable).  */
7544
7545   if (! ffecom_transform_only_dummies_
7546       && ffesymbol_assigned (s)
7547       && ! ffesymbol_hook (s).assign_tree)
7548     s = ffecom_sym_transform_assign_ (s);
7549
7550   if (ffesymbol_sfdummyparent (s) == NULL)
7551     {
7552       input_filename = ffesymbol_where_filename (s);
7553       lineno = ffesymbol_where_filelinenum (s);
7554     }
7555   else
7556     {
7557       ffesymbol sf = ffesymbol_sfdummyparent (s);
7558
7559       input_filename = ffesymbol_where_filename (sf);
7560       lineno = ffesymbol_where_filelinenum (sf);
7561     }
7562
7563   bt = ffeinfo_basictype (ffebld_info (s));
7564   kt = ffeinfo_kindtype (ffebld_info (s));
7565
7566   t = NULL_TREE;
7567   tlen = NULL_TREE;
7568   addr = FALSE;
7569
7570   switch (ffesymbol_kind (s))
7571     {
7572     case FFEINFO_kindNONE:
7573       switch (ffesymbol_where (s))
7574         {
7575         case FFEINFO_whereDUMMY:        /* Subroutine or function. */
7576           assert (ffecom_transform_only_dummies_);
7577
7578           /* Before 0.4, this could be ENTITY/DUMMY, but see
7579              ffestu_sym_end_transition -- no longer true (in particular, if
7580              it could be an ENTITY, it _will_ be made one, so that
7581              possibility won't come through here).  So we never make length
7582              arg for CHARACTER type.  */
7583
7584           t = build_decl (PARM_DECL,
7585                           ffecom_get_identifier_ (ffesymbol_text (s)),
7586                           ffecom_tree_ptr_to_subr_type);
7587 #if BUILT_FOR_270
7588           DECL_ARTIFICIAL (t) = 1;
7589 #endif
7590           addr = TRUE;
7591           break;
7592
7593         case FFEINFO_whereGLOBAL:       /* Subroutine or function. */
7594           assert (!ffecom_transform_only_dummies_);
7595
7596           if (((g = ffesymbol_global (s)) != NULL)
7597               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7598                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7599                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
7600               && (ffeglobal_hook (g) != NULL_TREE)
7601               && ffe_is_globals ())
7602             {
7603               t = ffeglobal_hook (g);
7604               break;
7605             }
7606
7607           t = build_decl (FUNCTION_DECL,
7608                           ffecom_get_external_identifier_ (s),
7609                           ffecom_tree_subr_type);       /* Assume subr. */
7610           DECL_EXTERNAL (t) = 1;
7611           TREE_PUBLIC (t) = 1;
7612
7613           t = start_decl (t, FALSE);
7614           finish_decl (t, NULL_TREE, FALSE);
7615
7616           if ((g != NULL)
7617               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7618                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7619                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
7620             ffeglobal_set_hook (g, t);
7621
7622           ffecom_save_tree_forever (t);
7623
7624           break;
7625
7626         default:
7627           assert ("NONE where unexpected" == NULL);
7628           /* Fall through. */
7629         case FFEINFO_whereANY:
7630           break;
7631         }
7632       break;
7633
7634     case FFEINFO_kindENTITY:
7635       switch (ffeinfo_where (ffesymbol_info (s)))
7636         {
7637
7638         case FFEINFO_whereCONSTANT:
7639           /* ~~Debugging info needed? */
7640           assert (!ffecom_transform_only_dummies_);
7641           t = error_mark_node;  /* Shouldn't ever see this in expr. */
7642           break;
7643
7644         case FFEINFO_whereLOCAL:
7645           assert (!ffecom_transform_only_dummies_);
7646
7647           {
7648             ffestorag st = ffesymbol_storage (s);
7649             tree type;
7650
7651             if ((st != NULL)
7652                 && (ffestorag_size (st) == 0))
7653               {
7654                 t = error_mark_node;
7655                 break;
7656               }
7657
7658             yes = suspend_momentary ();
7659             type = ffecom_type_localvar_ (s, bt, kt);
7660             resume_momentary (yes);
7661
7662             if (type == error_mark_node)
7663               {
7664                 t = error_mark_node;
7665                 break;
7666               }
7667
7668             if ((st != NULL)
7669                 && (ffestorag_parent (st) != NULL))
7670               {                 /* Child of EQUIVALENCE parent. */
7671                 ffestorag est;
7672                 tree et;
7673                 int yes;
7674                 ffetargetOffset offset;
7675
7676                 est = ffestorag_parent (st);
7677                 ffecom_transform_equiv_ (est);
7678
7679                 et = ffestorag_hook (est);
7680                 assert (et != NULL_TREE);
7681
7682                 if (! TREE_STATIC (et))
7683                   put_var_into_stack (et);
7684
7685                 yes = suspend_momentary ();
7686
7687                 offset = ffestorag_modulo (est)
7688                   + ffestorag_offset (ffesymbol_storage (s))
7689                   - ffestorag_offset (est);
7690
7691                 ffecom_debug_kludge_ (et, "EQUIVALENCE", s, type, offset);
7692
7693                 /* (t_type *) (((char *) &et) + offset) */
7694
7695                 t = convert (string_type_node,  /* (char *) */
7696                              ffecom_1 (ADDR_EXPR,
7697                                        build_pointer_type (TREE_TYPE (et)),
7698                                        et));
7699                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
7700                               t,
7701                               build_int_2 (offset, 0));
7702                 t = convert (build_pointer_type (type),
7703                              t);
7704                 TREE_CONSTANT (t) = staticp (et);
7705
7706                 addr = TRUE;
7707
7708                 resume_momentary (yes);
7709               }
7710             else
7711               {
7712                 tree initexpr;
7713                 bool init = ffesymbol_is_init (s);
7714
7715                 yes = suspend_momentary ();
7716
7717                 t = build_decl (VAR_DECL,
7718                                 ffecom_get_identifier_ (ffesymbol_text (s)),
7719                                 type);
7720
7721                 if (init
7722                     || ffesymbol_namelisted (s)
7723 #ifdef FFECOM_sizeMAXSTACKITEM
7724                     || ((st != NULL)
7725                         && (ffestorag_size (st) > FFECOM_sizeMAXSTACKITEM))
7726 #endif
7727                     || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
7728                         && (ffecom_primary_entry_kind_
7729                             != FFEINFO_kindBLOCKDATA)
7730                         && (ffesymbol_is_save (s) || ffe_is_saveall ())))
7731                   TREE_STATIC (t) = !ffesymbol_attr (s, FFESYMBOL_attrADJUSTABLE);
7732                 else
7733                   TREE_STATIC (t) = 0;  /* No need to make static. */
7734
7735                 if (init || ffe_is_init_local_zero ())
7736                   DECL_INITIAL (t) = error_mark_node;
7737
7738                 /* Keep -Wunused from complaining about var if it
7739                    is used as sfunc arg or DATA implied-DO.  */
7740                 if (ffesymbol_attrs (s) & FFESYMBOL_attrsSFARG)
7741                   DECL_IN_SYSTEM_HEADER (t) = 1;
7742
7743                 t = start_decl (t, FALSE);
7744
7745                 if (init)
7746                   {
7747                     if (ffesymbol_init (s) != NULL)
7748                       initexpr = ffecom_expr (ffesymbol_init (s));
7749                     else
7750                       initexpr = ffecom_init_zero_ (t);
7751                   }
7752                 else if (ffe_is_init_local_zero ())
7753                   initexpr = ffecom_init_zero_ (t);
7754                 else
7755                   initexpr = NULL_TREE; /* Not ref'd if !init. */
7756
7757                 finish_decl (t, initexpr, FALSE);
7758
7759                 if (st != NULL && DECL_SIZE (t) != error_mark_node)
7760                   {
7761                     assert (TREE_CODE (DECL_SIZE_UNIT (t)) == INTEGER_CST);
7762                     assert (0 == compare_tree_int (DECL_SIZE_UNIT (t),
7763                                                    ffestorag_size (st)));
7764                   }
7765
7766                 resume_momentary (yes);
7767               }
7768           }
7769           break;
7770
7771         case FFEINFO_whereRESULT:
7772           assert (!ffecom_transform_only_dummies_);
7773
7774           if (bt == FFEINFO_basictypeCHARACTER)
7775             {                   /* Result is already in list of dummies, use
7776                                    it (& length). */
7777               t = ffecom_func_result_;
7778               tlen = ffecom_func_length_;
7779               addr = TRUE;
7780               break;
7781             }
7782           if ((ffecom_num_entrypoints_ == 0)
7783               && (bt == FFEINFO_basictypeCOMPLEX)
7784               && (ffesymbol_is_f2c (ffecom_primary_entry_)))
7785             {                   /* Result is already in list of dummies, use
7786                                    it. */
7787               t = ffecom_func_result_;
7788               addr = TRUE;
7789               break;
7790             }
7791           if (ffecom_func_result_ != NULL_TREE)
7792             {
7793               t = ffecom_func_result_;
7794               break;
7795             }
7796           if ((ffecom_num_entrypoints_ != 0)
7797               && (ffecom_master_bt_ == FFEINFO_basictypeNONE))
7798             {
7799               yes = suspend_momentary ();
7800
7801               assert (ffecom_multi_retval_ != NULL_TREE);
7802               t = ffecom_1 (INDIRECT_REF, ffecom_multi_type_node_,
7803                             ffecom_multi_retval_);
7804               t = ffecom_2 (COMPONENT_REF, ffecom_tree_type[bt][kt],
7805                             t, ffecom_multi_fields_[bt][kt]);
7806
7807               resume_momentary (yes);
7808               break;
7809             }
7810
7811           yes = suspend_momentary ();
7812
7813           t = build_decl (VAR_DECL,
7814                           ffecom_get_identifier_ (ffesymbol_text (s)),
7815                           ffecom_tree_type[bt][kt]);
7816           TREE_STATIC (t) = 0;  /* Put result on stack. */
7817           t = start_decl (t, FALSE);
7818           finish_decl (t, NULL_TREE, FALSE);
7819
7820           ffecom_func_result_ = t;
7821
7822           resume_momentary (yes);
7823           break;
7824
7825         case FFEINFO_whereDUMMY:
7826           {
7827             tree type;
7828             ffebld dl;
7829             ffebld dim;
7830             tree low;
7831             tree high;
7832             tree old_sizes;
7833             bool adjustable = FALSE;    /* Conditionally adjustable? */
7834
7835             type = ffecom_tree_type[bt][kt];
7836             if (ffesymbol_sfdummyparent (s) != NULL)
7837               {
7838                 if (current_function_decl == ffecom_outer_function_decl_)
7839                   {                     /* Exec transition before sfunc
7840                                            context; get it later. */
7841                     break;
7842                   }
7843                 t = ffecom_get_identifier_ (ffesymbol_text
7844                                             (ffesymbol_sfdummyparent (s)));
7845               }
7846             else
7847               t = ffecom_get_identifier_ (ffesymbol_text (s));
7848
7849             assert (ffecom_transform_only_dummies_);
7850
7851             old_sizes = get_pending_sizes ();
7852             put_pending_sizes (old_sizes);
7853
7854             if (bt == FFEINFO_basictypeCHARACTER)
7855               tlen = ffecom_char_enhance_arg_ (&type, s);
7856             type = ffecom_check_size_overflow_ (s, type, TRUE);
7857
7858             for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
7859               {
7860                 if (type == error_mark_node)
7861                   break;
7862
7863                 dim = ffebld_head (dl);
7864                 assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
7865                 if ((ffebld_left (dim) == NULL) || ffecom_doing_entry_)
7866                   low = ffecom_integer_one_node;
7867                 else
7868                   low = ffecom_expr (ffebld_left (dim));
7869                 assert (ffebld_right (dim) != NULL);
7870                 if ((ffebld_op (ffebld_right (dim)) == FFEBLD_opSTAR)
7871                     || ffecom_doing_entry_)
7872                   {
7873                     /* Used to just do high=low.  But for ffecom_tree_
7874                        canonize_ref_, it probably is important to correctly
7875                        assess the size.  E.g. given COMPLEX C(*),CFUNC and
7876                        C(2)=CFUNC(C), overlap can happen, while it can't
7877                        for, say, C(1)=CFUNC(C(2)).  */
7878                     /* Even more recently used to set to INT_MAX, but that
7879                        broke when some overflow checking went into the back
7880                        end.  Now we just leave the upper bound unspecified.  */
7881                     high = NULL;
7882                   }
7883                 else
7884                   high = ffecom_expr (ffebld_right (dim));
7885
7886                 /* Determine whether array is conditionally adjustable,
7887                    to decide whether back-end magic is needed.
7888
7889                    Normally the front end uses the back-end function
7890                    variable_size to wrap SAVE_EXPR's around expressions
7891                    affecting the size/shape of an array so that the
7892                    size/shape info doesn't change during execution
7893                    of the compiled code even though variables and
7894                    functions referenced in those expressions might.
7895
7896                    variable_size also makes sure those saved expressions
7897                    get evaluated immediately upon entry to the
7898                    compiled procedure -- the front end normally doesn't
7899                    have to worry about that.
7900
7901                    However, there is a problem with this that affects
7902                    g77's implementation of entry points, and that is
7903                    that it is _not_ true that each invocation of the
7904                    compiled procedure is permitted to evaluate
7905                    array size/shape info -- because it is possible
7906                    that, for some invocations, that info is invalid (in
7907                    which case it is "promised" -- i.e. a violation of
7908                    the Fortran standard -- that the compiled code
7909                    won't reference the array or its size/shape
7910                    during that particular invocation).
7911
7912                    To phrase this in C terms, consider this gcc function:
7913
7914                      void foo (int *n, float (*a)[*n])
7915                      {
7916                        // a is "pointer to array ...", fyi.
7917                      }
7918
7919                    Suppose that, for some invocations, it is permitted
7920                    for a caller of foo to do this:
7921
7922                        foo (NULL, NULL);
7923
7924                    Now the _written_ code for foo can take such a call
7925                    into account by either testing explicitly for whether
7926                    (a == NULL) || (n == NULL) -- presumably it is
7927                    not permitted to reference *a in various fashions
7928                    if (n == NULL) I suppose -- or it can avoid it by
7929                    looking at other info (other arguments, static/global
7930                    data, etc.).
7931
7932                    However, this won't work in gcc 2.5.8 because it'll
7933                    automatically emit the code to save the "*n"
7934                    expression, which'll yield a NULL dereference for
7935                    the "foo (NULL, NULL)" call, something the code
7936                    for foo cannot prevent.
7937
7938                    g77 definitely needs to avoid executing such
7939                    code anytime the pointer to the adjustable array
7940                    is NULL, because even if its bounds expressions
7941                    don't have any references to possible "absent"
7942                    variables like "*n" -- say all variable references
7943                    are to COMMON variables, i.e. global (though in C,
7944                    local static could actually make sense) -- the
7945                    expressions could yield other run-time problems
7946                    for allowably "dead" values in those variables.
7947
7948                    For example, let's consider a more complicated
7949                    version of foo:
7950
7951                      extern int i;
7952                      extern int j;
7953
7954                      void foo (float (*a)[i/j])
7955                      {
7956                        ...
7957                      }
7958
7959                    The above is (essentially) quite valid for Fortran
7960                    but, again, for a call like "foo (NULL);", it is
7961                    permitted for i and j to be undefined when the
7962                    call is made.  If j happened to be zero, for
7963                    example, emitting the code to evaluate "i/j"
7964                    could result in a run-time error.
7965
7966                    Offhand, though I don't have my F77 or F90
7967                    standards handy, it might even be valid for a
7968                    bounds expression to contain a function reference,
7969                    in which case I doubt it is permitted for an
7970                    implementation to invoke that function in the
7971                    Fortran case involved here (invocation of an
7972                    alternate ENTRY point that doesn't have the adjustable
7973                    array as one of its arguments).
7974
7975                    So, the code that the compiler would normally emit
7976                    to preevaluate the size/shape info for an
7977                    adjustable array _must not_ be executed at run time
7978                    in certain cases.  Specifically, for Fortran,
7979                    the case is when the pointer to the adjustable
7980                    array == NULL.  (For gnu-ish C, it might be nice
7981                    for the source code itself to specify an expression
7982                    that, if TRUE, inhibits execution of the code.  Or
7983                    reverse the sense for elegance.)
7984
7985                    (Note that g77 could use a different test than NULL,
7986                    actually, since it happens to always pass an
7987                    integer to the called function that specifies which
7988                    entry point is being invoked.  Hmm, this might
7989                    solve the next problem.)
7990
7991                    One way a user could, I suppose, write "foo" so
7992                    it works is to insert COND_EXPR's for the
7993                    size/shape info so the dangerous stuff isn't
7994                    actually done, as in:
7995
7996                      void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
7997                      {
7998                        ...
7999                      }
8000
8001                    The next problem is that the front end needs to
8002                    be able to tell the back end about the array's
8003                    decl _before_ it tells it about the conditional
8004                    expression to inhibit evaluation of size/shape info,
8005                    as shown above.
8006
8007                    To solve this, the front end needs to be able
8008                    to give the back end the expression to inhibit
8009                    generation of the preevaluation code _after_
8010                    it makes the decl for the adjustable array.
8011
8012                    Until then, the above example using the COND_EXPR
8013                    doesn't pass muster with gcc because the "(a == NULL)"
8014                    part has a reference to "a", which is still
8015                    undefined at that point.
8016
8017                    g77 will therefore use a different mechanism in the
8018                    meantime.  */
8019
8020                 if (!adjustable
8021                     && ((TREE_CODE (low) != INTEGER_CST)
8022                         || (high && TREE_CODE (high) != INTEGER_CST)))
8023                   adjustable = TRUE;
8024
8025 #if 0                           /* Old approach -- see below. */
8026                 if (TREE_CODE (low) != INTEGER_CST)
8027                   low = ffecom_3 (COND_EXPR, integer_type_node,
8028                                   ffecom_adjarray_passed_ (s),
8029                                   low,
8030                                   ffecom_integer_zero_node);
8031
8032                 if (high && TREE_CODE (high) != INTEGER_CST)
8033                   high = ffecom_3 (COND_EXPR, integer_type_node,
8034                                    ffecom_adjarray_passed_ (s),
8035                                    high,
8036                                    ffecom_integer_zero_node);
8037 #endif
8038
8039                 /* ~~~gcc/stor-layout.c (layout_type) should do this,
8040                    probably.  Fixes 950302-1.f.  */
8041
8042                 if (TREE_CODE (low) != INTEGER_CST)
8043                   low = variable_size (low);
8044
8045                 /* ~~~Similarly, this fixes dumb0.f.  The C front end
8046                    does this, which is why dumb0.c would work.  */
8047
8048                 if (high && TREE_CODE (high) != INTEGER_CST)
8049                   high = variable_size (high);
8050
8051                 type
8052                   = build_array_type
8053                     (type,
8054                      build_range_type (ffecom_integer_type_node,
8055                                        low, high));
8056                 type = ffecom_check_size_overflow_ (s, type, TRUE);
8057               }
8058
8059             if (type == error_mark_node)
8060               {
8061                 t = error_mark_node;
8062                 break;
8063               }
8064
8065             if ((ffesymbol_sfdummyparent (s) == NULL)
8066                  || (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
8067               {
8068                 type = build_pointer_type (type);
8069                 addr = TRUE;
8070               }
8071
8072             t = build_decl (PARM_DECL, t, type);
8073 #if BUILT_FOR_270
8074             DECL_ARTIFICIAL (t) = 1;
8075 #endif
8076
8077             /* If this arg is present in every entry point's list of
8078                dummy args, then we're done.  */
8079
8080             if (ffesymbol_numentries (s)
8081                 == (ffecom_num_entrypoints_ + 1))
8082               break;
8083
8084 #if 1
8085
8086             /* If variable_size in stor-layout has been called during
8087                the above, then get_pending_sizes should have the
8088                yet-to-be-evaluated saved expressions pending.
8089                Make the whole lot of them get emitted, conditionally
8090                on whether the array decl ("t" above) is not NULL.  */
8091
8092             {
8093               tree sizes = get_pending_sizes ();
8094               tree tem;
8095
8096               for (tem = sizes;
8097                    tem != old_sizes;
8098                    tem = TREE_CHAIN (tem))
8099                 {
8100                   tree temv = TREE_VALUE (tem);
8101
8102                   if (sizes == tem)
8103                     sizes = temv;
8104                   else
8105                     sizes
8106                       = ffecom_2 (COMPOUND_EXPR,
8107                                   TREE_TYPE (sizes),
8108                                   temv,
8109                                   sizes);
8110                 }
8111
8112               if (sizes != tem)
8113                 {
8114                   sizes
8115                     = ffecom_3 (COND_EXPR,
8116                                 TREE_TYPE (sizes),
8117                                 ffecom_2 (NE_EXPR,
8118                                           integer_type_node,
8119                                           t,
8120                                           null_pointer_node),
8121                                 sizes,
8122                                 convert (TREE_TYPE (sizes),
8123                                          integer_zero_node));
8124                   sizes = ffecom_save_tree (sizes);
8125
8126                   sizes
8127                     = tree_cons (NULL_TREE, sizes, tem);
8128                 }
8129
8130               if (sizes)
8131                 put_pending_sizes (sizes);
8132             }
8133
8134 #else
8135 #if 0
8136             if (adjustable
8137                 && (ffesymbol_numentries (s)
8138                     != ffecom_num_entrypoints_ + 1))
8139               DECL_SOMETHING (t)
8140                 = ffecom_2 (NE_EXPR, integer_type_node,
8141                             t,
8142                             null_pointer_node);
8143 #else
8144 #if 0
8145             if (adjustable
8146                 && (ffesymbol_numentries (s)
8147                     != ffecom_num_entrypoints_ + 1))
8148               {
8149                 ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED);
8150                 ffebad_here (0, ffesymbol_where_line (s),
8151                              ffesymbol_where_column (s));
8152                 ffebad_string (ffesymbol_text (s));
8153                 ffebad_finish ();
8154               }
8155 #endif
8156 #endif
8157 #endif
8158           }
8159           break;
8160
8161         case FFEINFO_whereCOMMON:
8162           {
8163             ffesymbol cs;
8164             ffeglobal cg;
8165             tree ct;
8166             ffestorag st = ffesymbol_storage (s);
8167             tree type;
8168             int yes;
8169
8170             cs = ffesymbol_common (s);  /* The COMMON area itself.  */
8171             if (st != NULL)     /* Else not laid out. */
8172               {
8173                 ffecom_transform_common_ (cs);
8174                 st = ffesymbol_storage (s);
8175               }
8176
8177             yes = suspend_momentary ();
8178
8179             type = ffecom_type_localvar_ (s, bt, kt);
8180
8181             cg = ffesymbol_global (cs); /* The global COMMON info.  */
8182             if ((cg == NULL)
8183                 || (ffeglobal_type (cg) != FFEGLOBAL_typeCOMMON))
8184               ct = NULL_TREE;
8185             else
8186               ct = ffeglobal_hook (cg); /* The common area's tree.  */
8187
8188             if ((ct == NULL_TREE)
8189                 || (st == NULL)
8190                 || (type == error_mark_node))
8191               t = error_mark_node;
8192             else
8193               {
8194                 ffetargetOffset offset;
8195                 ffestorag cst;
8196
8197                 cst = ffestorag_parent (st);
8198                 assert (cst == ffesymbol_storage (cs));
8199
8200                 offset = ffestorag_modulo (cst)
8201                   + ffestorag_offset (st)
8202                   - ffestorag_offset (cst);
8203
8204                 ffecom_debug_kludge_ (ct, "COMMON", s, type, offset);
8205
8206                 /* (t_type *) (((char *) &ct) + offset) */
8207
8208                 t = convert (string_type_node,  /* (char *) */
8209                              ffecom_1 (ADDR_EXPR,
8210                                        build_pointer_type (TREE_TYPE (ct)),
8211                                        ct));
8212                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
8213                               t,
8214                               build_int_2 (offset, 0));
8215                 t = convert (build_pointer_type (type),
8216                              t);
8217                 TREE_CONSTANT (t) = 1;
8218
8219                 addr = TRUE;
8220               }
8221
8222             resume_momentary (yes);
8223           }
8224           break;
8225
8226         case FFEINFO_whereIMMEDIATE:
8227         case FFEINFO_whereGLOBAL:
8228         case FFEINFO_whereFLEETING:
8229         case FFEINFO_whereFLEETING_CADDR:
8230         case FFEINFO_whereFLEETING_IADDR:
8231         case FFEINFO_whereINTRINSIC:
8232         case FFEINFO_whereCONSTANT_SUBOBJECT:
8233         default:
8234           assert ("ENTITY where unheard of" == NULL);
8235           /* Fall through. */
8236         case FFEINFO_whereANY:
8237           t = error_mark_node;
8238           break;
8239         }
8240       break;
8241
8242     case FFEINFO_kindFUNCTION:
8243       switch (ffeinfo_where (ffesymbol_info (s)))
8244         {
8245         case FFEINFO_whereLOCAL:        /* Me. */
8246           assert (!ffecom_transform_only_dummies_);
8247           t = current_function_decl;
8248           break;
8249
8250         case FFEINFO_whereGLOBAL:
8251           assert (!ffecom_transform_only_dummies_);
8252
8253           if (((g = ffesymbol_global (s)) != NULL)
8254               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8255                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8256               && (ffeglobal_hook (g) != NULL_TREE)
8257               && ffe_is_globals ())
8258             {
8259               t = ffeglobal_hook (g);
8260               break;
8261             }
8262
8263           if (ffesymbol_is_f2c (s)
8264               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8265             t = ffecom_tree_fun_type[bt][kt];
8266           else
8267             t = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
8268
8269           t = build_decl (FUNCTION_DECL,
8270                           ffecom_get_external_identifier_ (s),
8271                           t);
8272           DECL_EXTERNAL (t) = 1;
8273           TREE_PUBLIC (t) = 1;
8274
8275           t = start_decl (t, FALSE);
8276           finish_decl (t, NULL_TREE, FALSE);
8277
8278           if ((g != NULL)
8279               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8280                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8281             ffeglobal_set_hook (g, t);
8282
8283           ffecom_save_tree_forever (t);
8284
8285           break;
8286
8287         case FFEINFO_whereDUMMY:
8288           assert (ffecom_transform_only_dummies_);
8289
8290           if (ffesymbol_is_f2c (s)
8291               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8292             t = ffecom_tree_ptr_to_fun_type[bt][kt];
8293           else
8294             t = build_pointer_type
8295               (build_function_type (ffecom_tree_type[bt][kt], NULL_TREE));
8296
8297           t = build_decl (PARM_DECL,
8298                           ffecom_get_identifier_ (ffesymbol_text (s)),
8299                           t);
8300 #if BUILT_FOR_270
8301           DECL_ARTIFICIAL (t) = 1;
8302 #endif
8303           addr = TRUE;
8304           break;
8305
8306         case FFEINFO_whereCONSTANT:     /* Statement function. */
8307           assert (!ffecom_transform_only_dummies_);
8308           t = ffecom_gen_sfuncdef_ (s, bt, kt);
8309           break;
8310
8311         case FFEINFO_whereINTRINSIC:
8312           assert (!ffecom_transform_only_dummies_);
8313           break;                /* Let actual references generate their
8314                                    decls. */
8315
8316         default:
8317           assert ("FUNCTION where unheard of" == NULL);
8318           /* Fall through. */
8319         case FFEINFO_whereANY:
8320           t = error_mark_node;
8321           break;
8322         }
8323       break;
8324
8325     case FFEINFO_kindSUBROUTINE:
8326       switch (ffeinfo_where (ffesymbol_info (s)))
8327         {
8328         case FFEINFO_whereLOCAL:        /* Me. */
8329           assert (!ffecom_transform_only_dummies_);
8330           t = current_function_decl;
8331           break;
8332
8333         case FFEINFO_whereGLOBAL:
8334           assert (!ffecom_transform_only_dummies_);
8335
8336           if (((g = ffesymbol_global (s)) != NULL)
8337               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8338                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8339               && (ffeglobal_hook (g) != NULL_TREE)
8340               && ffe_is_globals ())
8341             {
8342               t = ffeglobal_hook (g);
8343               break;
8344             }
8345
8346           t = build_decl (FUNCTION_DECL,
8347                           ffecom_get_external_identifier_ (s),
8348                           ffecom_tree_subr_type);
8349           DECL_EXTERNAL (t) = 1;
8350           TREE_PUBLIC (t) = 1;
8351
8352           t = start_decl (t, FALSE);
8353           finish_decl (t, NULL_TREE, FALSE);
8354
8355           if ((g != NULL)
8356               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8357                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8358             ffeglobal_set_hook (g, t);
8359
8360           ffecom_save_tree_forever (t);
8361
8362           break;
8363
8364         case FFEINFO_whereDUMMY:
8365           assert (ffecom_transform_only_dummies_);
8366
8367           t = build_decl (PARM_DECL,
8368                           ffecom_get_identifier_ (ffesymbol_text (s)),
8369                           ffecom_tree_ptr_to_subr_type);
8370 #if BUILT_FOR_270
8371           DECL_ARTIFICIAL (t) = 1;
8372 #endif
8373           addr = TRUE;
8374           break;
8375
8376         case FFEINFO_whereINTRINSIC:
8377           assert (!ffecom_transform_only_dummies_);
8378           break;                /* Let actual references generate their
8379                                    decls. */
8380
8381         default:
8382           assert ("SUBROUTINE where unheard of" == NULL);
8383           /* Fall through. */
8384         case FFEINFO_whereANY:
8385           t = error_mark_node;
8386           break;
8387         }
8388       break;
8389
8390     case FFEINFO_kindPROGRAM:
8391       switch (ffeinfo_where (ffesymbol_info (s)))
8392         {
8393         case FFEINFO_whereLOCAL:        /* Me. */
8394           assert (!ffecom_transform_only_dummies_);
8395           t = current_function_decl;
8396           break;
8397
8398         case FFEINFO_whereCOMMON:
8399         case FFEINFO_whereDUMMY:
8400         case FFEINFO_whereGLOBAL:
8401         case FFEINFO_whereRESULT:
8402         case FFEINFO_whereFLEETING:
8403         case FFEINFO_whereFLEETING_CADDR:
8404         case FFEINFO_whereFLEETING_IADDR:
8405         case FFEINFO_whereIMMEDIATE:
8406         case FFEINFO_whereINTRINSIC:
8407         case FFEINFO_whereCONSTANT:
8408         case FFEINFO_whereCONSTANT_SUBOBJECT:
8409         default:
8410           assert ("PROGRAM where unheard of" == NULL);
8411           /* Fall through. */
8412         case FFEINFO_whereANY:
8413           t = error_mark_node;
8414           break;
8415         }
8416       break;
8417
8418     case FFEINFO_kindBLOCKDATA:
8419       switch (ffeinfo_where (ffesymbol_info (s)))
8420         {
8421         case FFEINFO_whereLOCAL:        /* Me. */
8422           assert (!ffecom_transform_only_dummies_);
8423           t = current_function_decl;
8424           break;
8425
8426         case FFEINFO_whereGLOBAL:
8427           assert (!ffecom_transform_only_dummies_);
8428
8429           t = build_decl (FUNCTION_DECL,
8430                           ffecom_get_external_identifier_ (s),
8431                           ffecom_tree_blockdata_type);
8432           DECL_EXTERNAL (t) = 1;
8433           TREE_PUBLIC (t) = 1;
8434
8435           t = start_decl (t, FALSE);
8436           finish_decl (t, NULL_TREE, FALSE);
8437
8438           ffecom_save_tree_forever (t);
8439
8440           break;
8441
8442         case FFEINFO_whereCOMMON:
8443         case FFEINFO_whereDUMMY:
8444         case FFEINFO_whereRESULT:
8445         case FFEINFO_whereFLEETING:
8446         case FFEINFO_whereFLEETING_CADDR:
8447         case FFEINFO_whereFLEETING_IADDR:
8448         case FFEINFO_whereIMMEDIATE:
8449         case FFEINFO_whereINTRINSIC:
8450         case FFEINFO_whereCONSTANT:
8451         case FFEINFO_whereCONSTANT_SUBOBJECT:
8452         default:
8453           assert ("BLOCKDATA where unheard of" == NULL);
8454           /* Fall through. */
8455         case FFEINFO_whereANY:
8456           t = error_mark_node;
8457           break;
8458         }
8459       break;
8460
8461     case FFEINFO_kindCOMMON:
8462       switch (ffeinfo_where (ffesymbol_info (s)))
8463         {
8464         case FFEINFO_whereLOCAL:
8465           assert (!ffecom_transform_only_dummies_);
8466           ffecom_transform_common_ (s);
8467           break;
8468
8469         case FFEINFO_whereNONE:
8470         case FFEINFO_whereCOMMON:
8471         case FFEINFO_whereDUMMY:
8472         case FFEINFO_whereGLOBAL:
8473         case FFEINFO_whereRESULT:
8474         case FFEINFO_whereFLEETING:
8475         case FFEINFO_whereFLEETING_CADDR:
8476         case FFEINFO_whereFLEETING_IADDR:
8477         case FFEINFO_whereIMMEDIATE:
8478         case FFEINFO_whereINTRINSIC:
8479         case FFEINFO_whereCONSTANT:
8480         case FFEINFO_whereCONSTANT_SUBOBJECT:
8481         default:
8482           assert ("COMMON where unheard of" == NULL);
8483           /* Fall through. */
8484         case FFEINFO_whereANY:
8485           t = error_mark_node;
8486           break;
8487         }
8488       break;
8489
8490     case FFEINFO_kindCONSTRUCT:
8491       switch (ffeinfo_where (ffesymbol_info (s)))
8492         {
8493         case FFEINFO_whereLOCAL:
8494           assert (!ffecom_transform_only_dummies_);
8495           break;
8496
8497         case FFEINFO_whereNONE:
8498         case FFEINFO_whereCOMMON:
8499         case FFEINFO_whereDUMMY:
8500         case FFEINFO_whereGLOBAL:
8501         case FFEINFO_whereRESULT:
8502         case FFEINFO_whereFLEETING:
8503         case FFEINFO_whereFLEETING_CADDR:
8504         case FFEINFO_whereFLEETING_IADDR:
8505         case FFEINFO_whereIMMEDIATE:
8506         case FFEINFO_whereINTRINSIC:
8507         case FFEINFO_whereCONSTANT:
8508         case FFEINFO_whereCONSTANT_SUBOBJECT:
8509         default:
8510           assert ("CONSTRUCT where unheard of" == NULL);
8511           /* Fall through. */
8512         case FFEINFO_whereANY:
8513           t = error_mark_node;
8514           break;
8515         }
8516       break;
8517
8518     case FFEINFO_kindNAMELIST:
8519       switch (ffeinfo_where (ffesymbol_info (s)))
8520         {
8521         case FFEINFO_whereLOCAL:
8522           assert (!ffecom_transform_only_dummies_);
8523           t = ffecom_transform_namelist_ (s);
8524           break;
8525
8526         case FFEINFO_whereNONE:
8527         case FFEINFO_whereCOMMON:
8528         case FFEINFO_whereDUMMY:
8529         case FFEINFO_whereGLOBAL:
8530         case FFEINFO_whereRESULT:
8531         case FFEINFO_whereFLEETING:
8532         case FFEINFO_whereFLEETING_CADDR:
8533         case FFEINFO_whereFLEETING_IADDR:
8534         case FFEINFO_whereIMMEDIATE:
8535         case FFEINFO_whereINTRINSIC:
8536         case FFEINFO_whereCONSTANT:
8537         case FFEINFO_whereCONSTANT_SUBOBJECT:
8538         default:
8539           assert ("NAMELIST where unheard of" == NULL);
8540           /* Fall through. */
8541         case FFEINFO_whereANY:
8542           t = error_mark_node;
8543           break;
8544         }
8545       break;
8546
8547     default:
8548       assert ("kind unheard of" == NULL);
8549       /* Fall through. */
8550     case FFEINFO_kindANY:
8551       t = error_mark_node;
8552       break;
8553     }
8554
8555   ffesymbol_hook (s).decl_tree = t;
8556   ffesymbol_hook (s).length_tree = tlen;
8557   ffesymbol_hook (s).addr = addr;
8558
8559   lineno = old_lineno;
8560   input_filename = old_input_filename;
8561
8562   return s;
8563 }
8564
8565 #endif
8566 /* Transform into ASSIGNable symbol.
8567
8568    Symbol has already been transformed, but for whatever reason, the
8569    resulting decl_tree has been deemed not usable for an ASSIGN target.
8570    (E.g. it isn't wide enough to hold a pointer.)  So, here we invent
8571    another local symbol of type void * and stuff that in the assign_tree
8572    argument.  The F77/F90 standards allow this implementation.  */
8573
8574 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8575 static ffesymbol
8576 ffecom_sym_transform_assign_ (ffesymbol s)
8577 {
8578   tree t;                       /* Transformed thingy. */
8579   int yes;
8580   int old_lineno = lineno;
8581   const char *old_input_filename = input_filename;
8582
8583   if (ffesymbol_sfdummyparent (s) == NULL)
8584     {
8585       input_filename = ffesymbol_where_filename (s);
8586       lineno = ffesymbol_where_filelinenum (s);
8587     }
8588   else
8589     {
8590       ffesymbol sf = ffesymbol_sfdummyparent (s);
8591
8592       input_filename = ffesymbol_where_filename (sf);
8593       lineno = ffesymbol_where_filelinenum (sf);
8594     }
8595
8596   assert (!ffecom_transform_only_dummies_);
8597
8598   yes = suspend_momentary ();
8599
8600   t = build_decl (VAR_DECL,
8601                   ffecom_get_invented_identifier ("__g77_ASSIGN_%s",
8602                                                    ffesymbol_text (s)),
8603                   TREE_TYPE (null_pointer_node));
8604
8605   switch (ffesymbol_where (s))
8606     {
8607     case FFEINFO_whereLOCAL:
8608       /* Unlike for regular vars, SAVE status is easy to determine for
8609          ASSIGNed vars, since there's no initialization, there's no
8610          effective storage association (so "SAVE J" does not apply to
8611          K even given "EQUIVALENCE (J,K)"), there's no size issue
8612          to worry about, etc.  */
8613       if ((ffesymbol_is_save (s) || ffe_is_saveall ())
8614           && (ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8615           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA))
8616         TREE_STATIC (t) = 1;    /* SAVEd in proc, make static. */
8617       else
8618         TREE_STATIC (t) = 0;    /* No need to make static. */
8619       break;
8620
8621     case FFEINFO_whereCOMMON:
8622       TREE_STATIC (t) = 1;      /* Assume COMMONs always SAVEd. */
8623       break;
8624
8625     case FFEINFO_whereDUMMY:
8626       /* Note that twinning a DUMMY means the caller won't see
8627          the ASSIGNed value.  But both F77 and F90 allow implementations
8628          to do this, i.e. disallow Fortran code that would try and
8629          take advantage of actually putting a label into a variable
8630          via a dummy argument (or any other storage association, for
8631          that matter).  */
8632       TREE_STATIC (t) = 0;
8633       break;
8634
8635     default:
8636       TREE_STATIC (t) = 0;
8637       break;
8638     }
8639
8640   t = start_decl (t, FALSE);
8641   finish_decl (t, NULL_TREE, FALSE);
8642
8643   resume_momentary (yes);
8644
8645   ffesymbol_hook (s).assign_tree = t;
8646
8647   lineno = old_lineno;
8648   input_filename = old_input_filename;
8649
8650   return s;
8651 }
8652
8653 #endif
8654 /* Implement COMMON area in back end.
8655
8656    Because COMMON-based variables can be referenced in the dimension
8657    expressions of dummy (adjustable) arrays, and because dummies
8658    (in the gcc back end) need to be put in the outer binding level
8659    of a function (which has two binding levels, the outer holding
8660    the dummies and the inner holding the other vars), special care
8661    must be taken to handle COMMON areas.
8662
8663    The current strategy is basically to always tell the back end about
8664    the COMMON area as a top-level external reference to just a block
8665    of storage of the master type of that area (e.g. integer, real,
8666    character, whatever -- not a structure).  As a distinct action,
8667    if initial values are provided, tell the back end about the area
8668    as a top-level non-external (initialized) area and remember not to
8669    allow further initialization or expansion of the area.  Meanwhile,
8670    if no initialization happens at all, tell the back end about
8671    the largest size we've seen declared so the space does get reserved.
8672    (This function doesn't handle all that stuff, but it does some
8673    of the important things.)
8674
8675    Meanwhile, for COMMON variables themselves, just keep creating
8676    references like *((float *) (&common_area + offset)) each time
8677    we reference the variable.  In other words, don't make a VAR_DECL
8678    or any kind of component reference (like we used to do before 0.4),
8679    though we might do that as well just for debugging purposes (and
8680    stuff the rtl with the appropriate offset expression).  */
8681
8682 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8683 static void
8684 ffecom_transform_common_ (ffesymbol s)
8685 {
8686   ffestorag st = ffesymbol_storage (s);
8687   ffeglobal g = ffesymbol_global (s);
8688   tree cbt;
8689   tree cbtype;
8690   tree init;
8691   tree high;
8692   bool is_init = ffestorag_is_init (st);
8693
8694   assert (st != NULL);
8695
8696   if ((g == NULL)
8697       || (ffeglobal_type (g) != FFEGLOBAL_typeCOMMON))
8698     return;
8699
8700   /* First update the size of the area in global terms.  */
8701
8702   ffeglobal_size_common (s, ffestorag_size (st));
8703
8704   if (!ffeglobal_common_init (g))
8705     is_init = FALSE;    /* No explicit init, don't let erroneous joins init. */
8706
8707   cbt = ffeglobal_hook (g);
8708
8709   /* If we already have declared this common block for a previous program
8710      unit, and either we already initialized it or we don't have new
8711      initialization for it, just return what we have without changing it.  */
8712
8713   if ((cbt != NULL_TREE)
8714       && (!is_init
8715           || !DECL_EXTERNAL (cbt)))
8716     {
8717       if (st->hook == NULL) ffestorag_set_hook (st, cbt);
8718       return;
8719     }
8720
8721   /* Process inits.  */
8722
8723   if (is_init)
8724     {
8725       if (ffestorag_init (st) != NULL)
8726         {
8727           ffebld sexp;
8728
8729           /* Set the padding for the expression, so ffecom_expr
8730              knows to insert that many zeros.  */
8731           switch (ffebld_op (sexp = ffestorag_init (st)))
8732             {
8733             case FFEBLD_opCONTER:
8734               ffebld_conter_set_pad (sexp, ffestorag_modulo (st));
8735               break;
8736
8737             case FFEBLD_opARRTER:
8738               ffebld_arrter_set_pad (sexp, ffestorag_modulo (st));
8739               break;
8740
8741             case FFEBLD_opACCTER:
8742               ffebld_accter_set_pad (sexp, ffestorag_modulo (st));
8743               break;
8744
8745             default:
8746               assert ("bad op for cmn init (pad)" == NULL);
8747               break;
8748             }
8749
8750           init = ffecom_expr (sexp);
8751           if (init == error_mark_node)
8752             {                   /* Hopefully the back end complained! */
8753               init = NULL_TREE;
8754               if (cbt != NULL_TREE)
8755                 return;
8756             }
8757         }
8758       else
8759         init = error_mark_node;
8760     }
8761   else
8762     init = NULL_TREE;
8763
8764   /* cbtype must be permanently allocated!  */
8765
8766   /* Allocate the MAX of the areas so far, seen filewide.  */
8767   high = build_int_2 ((ffeglobal_common_size (g)
8768                        + ffeglobal_common_pad (g)) - 1, 0);
8769   TREE_TYPE (high) = ffecom_integer_type_node;
8770
8771   if (init)
8772     cbtype = build_array_type (char_type_node,
8773                                build_range_type (integer_type_node,
8774                                                  integer_zero_node,
8775                                                  high));
8776   else
8777     cbtype = build_array_type (char_type_node, NULL_TREE);
8778
8779   if (cbt == NULL_TREE)
8780     {
8781       cbt
8782         = build_decl (VAR_DECL,
8783                       ffecom_get_external_identifier_ (s),
8784                       cbtype);
8785       TREE_STATIC (cbt) = 1;
8786       TREE_PUBLIC (cbt) = 1;
8787     }
8788   else
8789     {
8790       assert (is_init);
8791       TREE_TYPE (cbt) = cbtype;
8792     }
8793   DECL_EXTERNAL (cbt) = init ? 0 : 1;
8794   DECL_INITIAL (cbt) = init ? error_mark_node : NULL_TREE;
8795
8796   cbt = start_decl (cbt, TRUE);
8797   if (ffeglobal_hook (g) != NULL)
8798     assert (cbt == ffeglobal_hook (g));
8799
8800   assert (!init || !DECL_EXTERNAL (cbt));
8801
8802   /* Make sure that any type can live in COMMON and be referenced
8803      without getting a bus error.  We could pick the most restrictive
8804      alignment of all entities actually placed in the COMMON, but
8805      this seems easy enough.  */
8806
8807   DECL_ALIGN (cbt) = BIGGEST_ALIGNMENT;
8808   DECL_USER_ALIGN (cbt) = 0;
8809
8810   if (is_init && (ffestorag_init (st) == NULL))
8811     init = ffecom_init_zero_ (cbt);
8812
8813   finish_decl (cbt, init, TRUE);
8814
8815   if (is_init)
8816     ffestorag_set_init (st, ffebld_new_any ());
8817
8818   if (init)
8819     {
8820       assert (DECL_SIZE_UNIT (cbt) != NULL_TREE);
8821       assert (TREE_CODE (DECL_SIZE_UNIT (cbt)) == INTEGER_CST);
8822       assert (0 == compare_tree_int (DECL_SIZE_UNIT (cbt),
8823                                      (ffeglobal_common_size (g)
8824                                       + ffeglobal_common_pad (g))));
8825     }
8826
8827   ffeglobal_set_hook (g, cbt);
8828
8829   ffestorag_set_hook (st, cbt);
8830
8831   ffecom_save_tree_forever (cbt);
8832 }
8833
8834 #endif
8835 /* Make master area for local EQUIVALENCE.  */
8836
8837 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8838 static void
8839 ffecom_transform_equiv_ (ffestorag eqst)
8840 {
8841   tree eqt;
8842   tree eqtype;
8843   tree init;
8844   tree high;
8845   bool is_init = ffestorag_is_init (eqst);
8846   int yes;
8847
8848   assert (eqst != NULL);
8849
8850   eqt = ffestorag_hook (eqst);
8851
8852   if (eqt != NULL_TREE)
8853     return;
8854
8855   /* Process inits.  */
8856
8857   if (is_init)
8858     {
8859       if (ffestorag_init (eqst) != NULL)
8860         {
8861           ffebld sexp;
8862
8863           /* Set the padding for the expression, so ffecom_expr
8864              knows to insert that many zeros.  */
8865           switch (ffebld_op (sexp = ffestorag_init (eqst)))
8866             {
8867             case FFEBLD_opCONTER:
8868               ffebld_conter_set_pad (sexp, ffestorag_modulo (eqst));
8869               break;
8870
8871             case FFEBLD_opARRTER:
8872               ffebld_arrter_set_pad (sexp, ffestorag_modulo (eqst));
8873               break;
8874
8875             case FFEBLD_opACCTER:
8876               ffebld_accter_set_pad (sexp, ffestorag_modulo (eqst));
8877               break;
8878
8879             default:
8880               assert ("bad op for eqv init (pad)" == NULL);
8881               break;
8882             }
8883
8884           init = ffecom_expr (sexp);
8885           if (init == error_mark_node)
8886             init = NULL_TREE;   /* Hopefully the back end complained! */
8887         }
8888       else
8889         init = error_mark_node;
8890     }
8891   else if (ffe_is_init_local_zero ())
8892     init = error_mark_node;
8893   else
8894     init = NULL_TREE;
8895
8896   ffecom_member_namelisted_ = FALSE;
8897   ffestorag_drive (ffestorag_list_equivs (eqst),
8898                    &ffecom_member_phase1_,
8899                    eqst);
8900
8901   yes = suspend_momentary ();
8902
8903   high = build_int_2 ((ffestorag_size (eqst)
8904                        + ffestorag_modulo (eqst)) - 1, 0);
8905   TREE_TYPE (high) = ffecom_integer_type_node;
8906
8907   eqtype = build_array_type (char_type_node,
8908                              build_range_type (ffecom_integer_type_node,
8909                                                ffecom_integer_zero_node,
8910                                                high));
8911
8912   eqt = build_decl (VAR_DECL,
8913                     ffecom_get_invented_identifier ("__g77_equiv_%s",
8914                                                     ffesymbol_text
8915                                                     (ffestorag_symbol (eqst))),
8916                     eqtype);
8917   DECL_EXTERNAL (eqt) = 0;
8918   if (is_init
8919       || ffecom_member_namelisted_
8920 #ifdef FFECOM_sizeMAXSTACKITEM
8921       || (ffestorag_size (eqst) > FFECOM_sizeMAXSTACKITEM)
8922 #endif
8923       || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8924           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
8925           && (ffestorag_is_save (eqst) || ffe_is_saveall ())))
8926     TREE_STATIC (eqt) = 1;
8927   else
8928     TREE_STATIC (eqt) = 0;
8929   TREE_PUBLIC (eqt) = 0;
8930   DECL_CONTEXT (eqt) = current_function_decl;
8931   if (init)
8932     DECL_INITIAL (eqt) = error_mark_node;
8933   else
8934     DECL_INITIAL (eqt) = NULL_TREE;
8935
8936   eqt = start_decl (eqt, FALSE);
8937
8938   /* Make sure that any type can live in EQUIVALENCE and be referenced
8939      without getting a bus error.  We could pick the most restrictive
8940      alignment of all entities actually placed in the EQUIVALENCE, but
8941      this seems easy enough.  */
8942
8943   DECL_ALIGN (eqt) = BIGGEST_ALIGNMENT;
8944   DECL_USER_ALIGN (eqt) = 0;
8945
8946   if ((!is_init && ffe_is_init_local_zero ())
8947       || (is_init && (ffestorag_init (eqst) == NULL)))
8948     init = ffecom_init_zero_ (eqt);
8949
8950   finish_decl (eqt, init, FALSE);
8951
8952   if (is_init)
8953     ffestorag_set_init (eqst, ffebld_new_any ());
8954
8955   {
8956     assert (TREE_CODE (DECL_SIZE_UNIT (eqt)) == INTEGER_CST);
8957     assert (0 == compare_tree_int (DECL_SIZE_UNIT (eqt),
8958                                    (ffestorag_size (eqst)
8959                                     + ffestorag_modulo (eqst))));
8960   }
8961
8962   ffestorag_set_hook (eqst, eqt);
8963
8964 #ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
8965   ffestorag_drive (ffestorag_list_equivs (eqst),
8966                    &ffecom_member_phase2_,
8967                    eqst);
8968 #endif
8969
8970   resume_momentary (yes);
8971 }
8972
8973 #endif
8974 /* Implement NAMELIST in back end.  See f2c/format.c for more info.  */
8975
8976 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8977 static tree
8978 ffecom_transform_namelist_ (ffesymbol s)
8979 {
8980   tree nmlt;
8981   tree nmltype = ffecom_type_namelist_ ();
8982   tree nmlinits;
8983   tree nameinit;
8984   tree varsinit;
8985   tree nvarsinit;
8986   tree field;
8987   tree high;
8988   int yes;
8989   int i;
8990   static int mynumber = 0;
8991
8992   yes = suspend_momentary ();
8993
8994   nmlt = build_decl (VAR_DECL,
8995                      ffecom_get_invented_identifier ("__g77_namelist_%d",
8996                                                      mynumber++),
8997                      nmltype);
8998   TREE_STATIC (nmlt) = 1;
8999   DECL_INITIAL (nmlt) = error_mark_node;
9000
9001   nmlt = start_decl (nmlt, FALSE);
9002
9003   /* Process inits.  */
9004
9005   i = strlen (ffesymbol_text (s));
9006
9007   high = build_int_2 (i, 0);
9008   TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
9009
9010   nameinit = ffecom_build_f2c_string_ (i + 1,
9011                                        ffesymbol_text (s));
9012   TREE_TYPE (nameinit)
9013     = build_type_variant
9014     (build_array_type
9015      (char_type_node,
9016       build_range_type (ffecom_f2c_ftnlen_type_node,
9017                         ffecom_f2c_ftnlen_one_node,
9018                         high)),
9019      1, 0);
9020   TREE_CONSTANT (nameinit) = 1;
9021   TREE_STATIC (nameinit) = 1;
9022   nameinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (nameinit)),
9023                        nameinit);
9024
9025   varsinit = ffecom_vardesc_array_ (s);
9026   varsinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (varsinit)),
9027                        varsinit);
9028   TREE_CONSTANT (varsinit) = 1;
9029   TREE_STATIC (varsinit) = 1;
9030
9031   {
9032     ffebld b;
9033
9034     for (i = 0, b = ffesymbol_namelist (s); b != NULL; b = ffebld_trail (b))
9035       ++i;
9036   }
9037   nvarsinit = build_int_2 (i, 0);
9038   TREE_TYPE (nvarsinit) = integer_type_node;
9039   TREE_CONSTANT (nvarsinit) = 1;
9040   TREE_STATIC (nvarsinit) = 1;
9041
9042   nmlinits = build_tree_list ((field = TYPE_FIELDS (nmltype)), nameinit);
9043   TREE_CHAIN (nmlinits) = build_tree_list ((field = TREE_CHAIN (field)),
9044                                            varsinit);
9045   TREE_CHAIN (TREE_CHAIN (nmlinits))
9046     = build_tree_list ((field = TREE_CHAIN (field)), nvarsinit);
9047
9048   nmlinits = build (CONSTRUCTOR, nmltype, NULL_TREE, nmlinits);
9049   TREE_CONSTANT (nmlinits) = 1;
9050   TREE_STATIC (nmlinits) = 1;
9051
9052   finish_decl (nmlt, nmlinits, FALSE);
9053
9054   nmlt = ffecom_1 (ADDR_EXPR, build_pointer_type (nmltype), nmlt);
9055
9056   resume_momentary (yes);
9057
9058   return nmlt;
9059 }
9060
9061 #endif
9062
9063 /* A subroutine of ffecom_tree_canonize_ref_.  The incoming tree is
9064    analyzed on the assumption it is calculating a pointer to be
9065    indirected through.  It must return the proper decl and offset,
9066    taking into account different units of measurements for offsets.  */
9067
9068 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9069 static void
9070 ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
9071                            tree t)
9072 {
9073   switch (TREE_CODE (t))
9074     {
9075     case NOP_EXPR:
9076     case CONVERT_EXPR:
9077     case NON_LVALUE_EXPR:
9078       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
9079       break;
9080
9081     case PLUS_EXPR:
9082       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
9083       if ((*decl == NULL_TREE)
9084           || (*decl == error_mark_node))
9085         break;
9086
9087       if (TREE_CODE (TREE_OPERAND (t, 1)) == INTEGER_CST)
9088         {
9089           /* An offset into COMMON.  */
9090           *offset = fold (build (PLUS_EXPR, TREE_TYPE (*offset),
9091                                  *offset, TREE_OPERAND (t, 1)));
9092           /* Convert offset (presumably in bytes) into canonical units
9093              (presumably bits).  */
9094           *offset = size_binop (MULT_EXPR,
9095                                 convert (bitsizetype, *offset),
9096                                 TYPE_SIZE (TREE_TYPE (TREE_TYPE (t))));
9097           break;
9098         }
9099       /* Not a COMMON reference, so an unrecognized pattern.  */
9100       *decl = error_mark_node;
9101       break;
9102
9103     case PARM_DECL:
9104       *decl = t;
9105       *offset = bitsize_zero_node;
9106       break;
9107
9108     case ADDR_EXPR:
9109       if (TREE_CODE (TREE_OPERAND (t, 0)) == VAR_DECL)
9110         {
9111           /* A reference to COMMON.  */
9112           *decl = TREE_OPERAND (t, 0);
9113           *offset = bitsize_zero_node;
9114           break;
9115         }
9116       /* Fall through.  */
9117     default:
9118       /* Not a COMMON reference, so an unrecognized pattern.  */
9119       *decl = error_mark_node;
9120       break;
9121     }
9122 }
9123 #endif
9124
9125 /* Given a tree that is possibly intended for use as an lvalue, return
9126    information representing a canonical view of that tree as a decl, an
9127    offset into that decl, and a size for the lvalue.
9128
9129    If there's no applicable decl, NULL_TREE is returned for the decl,
9130    and the other fields are left undefined.
9131
9132    If the tree doesn't fit the recognizable forms, an ERROR_MARK node
9133    is returned for the decl, and the other fields are left undefined.
9134
9135    Otherwise, the decl returned currently is either a VAR_DECL or a
9136    PARM_DECL.
9137
9138    The offset returned is always valid, but of course not necessarily
9139    a constant, and not necessarily converted into the appropriate
9140    type, leaving that up to the caller (so as to avoid that overhead
9141    if the decls being looked at are different anyway).
9142
9143    If the size cannot be determined (e.g. an adjustable array),
9144    an ERROR_MARK node is returned for the size.  Otherwise, the
9145    size returned is valid, not necessarily a constant, and not
9146    necessarily converted into the appropriate type as with the
9147    offset.
9148
9149    Note that the offset and size expressions are expressed in the
9150    base storage units (usually bits) rather than in the units of
9151    the type of the decl, because two decls with different types
9152    might overlap but with apparently non-overlapping array offsets,
9153    whereas converting the array offsets to consistant offsets will
9154    reveal the overlap.  */
9155
9156 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9157 static void
9158 ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
9159                            tree *size, tree t)
9160 {
9161   /* The default path is to report a nonexistant decl.  */
9162   *decl = NULL_TREE;
9163
9164   if (t == NULL_TREE)
9165     return;
9166
9167   switch (TREE_CODE (t))
9168     {
9169     case ERROR_MARK:
9170     case IDENTIFIER_NODE:
9171     case INTEGER_CST:
9172     case REAL_CST:
9173     case COMPLEX_CST:
9174     case STRING_CST:
9175     case CONST_DECL:
9176     case PLUS_EXPR:
9177     case MINUS_EXPR:
9178     case MULT_EXPR:
9179     case TRUNC_DIV_EXPR:
9180     case CEIL_DIV_EXPR:
9181     case FLOOR_DIV_EXPR:
9182     case ROUND_DIV_EXPR:
9183     case TRUNC_MOD_EXPR:
9184     case CEIL_MOD_EXPR:
9185     case FLOOR_MOD_EXPR:
9186     case ROUND_MOD_EXPR:
9187     case RDIV_EXPR:
9188     case EXACT_DIV_EXPR:
9189     case FIX_TRUNC_EXPR:
9190     case FIX_CEIL_EXPR:
9191     case FIX_FLOOR_EXPR:
9192     case FIX_ROUND_EXPR:
9193     case FLOAT_EXPR:
9194     case EXPON_EXPR:
9195     case NEGATE_EXPR:
9196     case MIN_EXPR:
9197     case MAX_EXPR:
9198     case ABS_EXPR:
9199     case FFS_EXPR:
9200     case LSHIFT_EXPR:
9201     case RSHIFT_EXPR:
9202     case LROTATE_EXPR:
9203     case RROTATE_EXPR:
9204     case BIT_IOR_EXPR:
9205     case BIT_XOR_EXPR:
9206     case BIT_AND_EXPR:
9207     case BIT_ANDTC_EXPR:
9208     case BIT_NOT_EXPR:
9209     case TRUTH_ANDIF_EXPR:
9210     case TRUTH_ORIF_EXPR:
9211     case TRUTH_AND_EXPR:
9212     case TRUTH_OR_EXPR:
9213     case TRUTH_XOR_EXPR:
9214     case TRUTH_NOT_EXPR:
9215     case LT_EXPR:
9216     case LE_EXPR:
9217     case GT_EXPR:
9218     case GE_EXPR:
9219     case EQ_EXPR:
9220     case NE_EXPR:
9221     case COMPLEX_EXPR:
9222     case CONJ_EXPR:
9223     case REALPART_EXPR:
9224     case IMAGPART_EXPR:
9225     case LABEL_EXPR:
9226     case COMPONENT_REF:
9227     case COMPOUND_EXPR:
9228     case ADDR_EXPR:
9229       return;
9230
9231     case VAR_DECL:
9232     case PARM_DECL:
9233       *decl = t;
9234       *offset = bitsize_zero_node;
9235       *size = TYPE_SIZE (TREE_TYPE (t));
9236       return;
9237
9238     case ARRAY_REF:
9239       {
9240         tree array = TREE_OPERAND (t, 0);
9241         tree element = TREE_OPERAND (t, 1);
9242         tree init_offset;
9243
9244         if ((array == NULL_TREE)
9245             || (element == NULL_TREE))
9246           {
9247             *decl = error_mark_node;
9248             return;
9249           }
9250
9251         ffecom_tree_canonize_ref_ (decl, &init_offset, size,
9252                                    array);
9253         if ((*decl == NULL_TREE)
9254             || (*decl == error_mark_node))
9255           return;
9256
9257         /* Calculate ((element - base) * NBBY) + init_offset.  */
9258         *offset = fold (build (MINUS_EXPR, TREE_TYPE (element),
9259                                element,
9260                                TYPE_MIN_VALUE (TYPE_DOMAIN
9261                                                (TREE_TYPE (array)))));
9262
9263         *offset = size_binop (MULT_EXPR,
9264                               convert (bitsizetype, *offset),
9265                               TYPE_SIZE (TREE_TYPE (TREE_TYPE (array))));
9266
9267         *offset = size_binop (PLUS_EXPR, init_offset, *offset);
9268
9269         *size = TYPE_SIZE (TREE_TYPE (t));
9270         return;
9271       }
9272
9273     case INDIRECT_REF:
9274
9275       /* Most of this code is to handle references to COMMON.  And so
9276          far that is useful only for calling library functions, since
9277          external (user) functions might reference common areas.  But
9278          even calling an external function, it's worthwhile to decode
9279          COMMON references because if not storing into COMMON, we don't
9280          want COMMON-based arguments to gratuitously force use of a
9281          temporary.  */
9282
9283       *size = TYPE_SIZE (TREE_TYPE (t));
9284
9285       ffecom_tree_canonize_ptr_ (decl, offset,
9286                                  TREE_OPERAND (t, 0));
9287
9288       return;
9289
9290     case CONVERT_EXPR:
9291     case NOP_EXPR:
9292     case MODIFY_EXPR:
9293     case NON_LVALUE_EXPR:
9294     case RESULT_DECL:
9295     case FIELD_DECL:
9296     case COND_EXPR:             /* More cases than we can handle. */
9297     case SAVE_EXPR:
9298     case REFERENCE_EXPR:
9299     case PREDECREMENT_EXPR:
9300     case PREINCREMENT_EXPR:
9301     case POSTDECREMENT_EXPR:
9302     case POSTINCREMENT_EXPR:
9303     case CALL_EXPR:
9304     default:
9305       *decl = error_mark_node;
9306       return;
9307     }
9308 }
9309 #endif
9310
9311 /* Do divide operation appropriate to type of operands.  */
9312
9313 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9314 static tree
9315 ffecom_tree_divide_ (tree tree_type, tree left, tree right,
9316                      tree dest_tree, ffebld dest, bool *dest_used,
9317                      tree hook)
9318 {
9319   if ((left == error_mark_node)
9320       || (right == error_mark_node))
9321     return error_mark_node;
9322
9323   switch (TREE_CODE (tree_type))
9324     {
9325     case INTEGER_TYPE:
9326       return ffecom_2 (TRUNC_DIV_EXPR, tree_type,
9327                        left,
9328                        right);
9329
9330     case COMPLEX_TYPE:
9331       if (! optimize_size)
9332         return ffecom_2 (RDIV_EXPR, tree_type,
9333                          left,
9334                          right);
9335       {
9336         ffecomGfrt ix;
9337
9338         if (TREE_TYPE (tree_type)
9339             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9340           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9341         else
9342           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9343
9344         left = ffecom_1 (ADDR_EXPR,
9345                          build_pointer_type (TREE_TYPE (left)),
9346                          left);
9347         left = build_tree_list (NULL_TREE, left);
9348         right = ffecom_1 (ADDR_EXPR,
9349                           build_pointer_type (TREE_TYPE (right)),
9350                           right);
9351         right = build_tree_list (NULL_TREE, right);
9352         TREE_CHAIN (left) = right;
9353
9354         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9355                              ffecom_gfrt_kindtype (ix),
9356                              ffe_is_f2c_library (),
9357                              tree_type,
9358                              left,
9359                              dest_tree, dest, dest_used,
9360                              NULL_TREE, TRUE, hook);
9361       }
9362       break;
9363
9364     case RECORD_TYPE:
9365       {
9366         ffecomGfrt ix;
9367
9368         if (TREE_TYPE (TYPE_FIELDS (tree_type))
9369             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9370           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9371         else
9372           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9373
9374         left = ffecom_1 (ADDR_EXPR,
9375                          build_pointer_type (TREE_TYPE (left)),
9376                          left);
9377         left = build_tree_list (NULL_TREE, left);
9378         right = ffecom_1 (ADDR_EXPR,
9379                           build_pointer_type (TREE_TYPE (right)),
9380                           right);
9381         right = build_tree_list (NULL_TREE, right);
9382         TREE_CHAIN (left) = right;
9383
9384         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9385                              ffecom_gfrt_kindtype (ix),
9386                              ffe_is_f2c_library (),
9387                              tree_type,
9388                              left,
9389                              dest_tree, dest, dest_used,
9390                              NULL_TREE, TRUE, hook);
9391       }
9392       break;
9393
9394     default:
9395       return ffecom_2 (RDIV_EXPR, tree_type,
9396                        left,
9397                        right);
9398     }
9399 }
9400
9401 #endif
9402 /* Build type info for non-dummy variable.  */
9403
9404 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9405 static tree
9406 ffecom_type_localvar_ (ffesymbol s, ffeinfoBasictype bt,
9407                        ffeinfoKindtype kt)
9408 {
9409   tree type;
9410   ffebld dl;
9411   ffebld dim;
9412   tree lowt;
9413   tree hight;
9414
9415   type = ffecom_tree_type[bt][kt];
9416   if (bt == FFEINFO_basictypeCHARACTER)
9417     {
9418       hight = build_int_2 (ffesymbol_size (s), 0);
9419       TREE_TYPE (hight) = ffecom_f2c_ftnlen_type_node;
9420
9421       type
9422         = build_array_type
9423           (type,
9424            build_range_type (ffecom_f2c_ftnlen_type_node,
9425                              ffecom_f2c_ftnlen_one_node,
9426                              hight));
9427       type = ffecom_check_size_overflow_ (s, type, FALSE);
9428     }
9429
9430   for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
9431     {
9432       if (type == error_mark_node)
9433         break;
9434
9435       dim = ffebld_head (dl);
9436       assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
9437
9438       if (ffebld_left (dim) == NULL)
9439         lowt = integer_one_node;
9440       else
9441         lowt = ffecom_expr (ffebld_left (dim));
9442
9443       if (TREE_CODE (lowt) != INTEGER_CST)
9444         lowt = variable_size (lowt);
9445
9446       assert (ffebld_right (dim) != NULL);
9447       hight = ffecom_expr (ffebld_right (dim));
9448
9449       if (TREE_CODE (hight) != INTEGER_CST)
9450         hight = variable_size (hight);
9451
9452       type = build_array_type (type,
9453                                build_range_type (ffecom_integer_type_node,
9454                                                  lowt, hight));
9455       type = ffecom_check_size_overflow_ (s, type, FALSE);
9456     }
9457
9458   return type;
9459 }
9460
9461 #endif
9462 /* Build Namelist type.  */
9463
9464 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9465 static tree
9466 ffecom_type_namelist_ ()
9467 {
9468   static tree type = NULL_TREE;
9469
9470   if (type == NULL_TREE)
9471     {
9472       static tree namefield, varsfield, nvarsfield;
9473       tree vardesctype;
9474
9475       vardesctype = ffecom_type_vardesc_ ();
9476
9477       type = make_node (RECORD_TYPE);
9478
9479       vardesctype = build_pointer_type (build_pointer_type (vardesctype));
9480
9481       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9482                                      string_type_node);
9483       varsfield = ffecom_decl_field (type, namefield, "vars", vardesctype);
9484       nvarsfield = ffecom_decl_field (type, varsfield, "nvars",
9485                                       integer_type_node);
9486
9487       TYPE_FIELDS (type) = namefield;
9488       layout_type (type);
9489
9490       ggc_add_tree_root (&type, 1);
9491     }
9492
9493   return type;
9494 }
9495
9496 #endif
9497
9498 /* Build Vardesc type.  */
9499
9500 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9501 static tree
9502 ffecom_type_vardesc_ ()
9503 {
9504   static tree type = NULL_TREE;
9505   static tree namefield, addrfield, dimsfield, typefield;
9506
9507   if (type == NULL_TREE)
9508     {
9509       type = make_node (RECORD_TYPE);
9510
9511       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9512                                      string_type_node);
9513       addrfield = ffecom_decl_field (type, namefield, "addr",
9514                                      string_type_node);
9515       dimsfield = ffecom_decl_field (type, addrfield, "dims",
9516                                      ffecom_f2c_ptr_to_ftnlen_type_node);
9517       typefield = ffecom_decl_field (type, dimsfield, "type",
9518                                      integer_type_node);
9519
9520       TYPE_FIELDS (type) = namefield;
9521       layout_type (type);
9522
9523       ggc_add_tree_root (&type, 1);
9524     }
9525
9526   return type;
9527 }
9528
9529 #endif
9530
9531 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9532 static tree
9533 ffecom_vardesc_ (ffebld expr)
9534 {
9535   ffesymbol s;
9536
9537   assert (ffebld_op (expr) == FFEBLD_opSYMTER);
9538   s = ffebld_symter (expr);
9539
9540   if (ffesymbol_hook (s).vardesc_tree == NULL_TREE)
9541     {
9542       int i;
9543       tree vardesctype = ffecom_type_vardesc_ ();
9544       tree var;
9545       tree nameinit;
9546       tree dimsinit;
9547       tree addrinit;
9548       tree typeinit;
9549       tree field;
9550       tree varinits;
9551       int yes;
9552       static int mynumber = 0;
9553
9554       yes = suspend_momentary ();
9555
9556       var = build_decl (VAR_DECL,
9557                         ffecom_get_invented_identifier ("__g77_vardesc_%d",
9558                                                         mynumber++),
9559                         vardesctype);
9560       TREE_STATIC (var) = 1;
9561       DECL_INITIAL (var) = error_mark_node;
9562
9563       var = start_decl (var, FALSE);
9564
9565       /* Process inits.  */
9566
9567       nameinit = ffecom_build_f2c_string_ ((i = strlen (ffesymbol_text (s)))
9568                                            + 1,
9569                                            ffesymbol_text (s));
9570       TREE_TYPE (nameinit)
9571         = build_type_variant
9572         (build_array_type
9573          (char_type_node,
9574           build_range_type (integer_type_node,
9575                             integer_one_node,
9576                             build_int_2 (i, 0))),
9577          1, 0);
9578       TREE_CONSTANT (nameinit) = 1;
9579       TREE_STATIC (nameinit) = 1;
9580       nameinit = ffecom_1 (ADDR_EXPR,
9581                            build_pointer_type (TREE_TYPE (nameinit)),
9582                            nameinit);
9583
9584       addrinit = ffecom_arg_ptr_to_expr (expr, &typeinit);
9585
9586       dimsinit = ffecom_vardesc_dims_ (s);
9587
9588       if (typeinit == NULL_TREE)
9589         {
9590           ffeinfoBasictype bt = ffesymbol_basictype (s);
9591           ffeinfoKindtype kt = ffesymbol_kindtype (s);
9592           int tc = ffecom_f2c_typecode (bt, kt);
9593
9594           assert (tc != -1);
9595           typeinit = build_int_2 (tc, (tc < 0) ? -1 : 0);
9596         }
9597       else
9598         typeinit = ffecom_1 (NEGATE_EXPR, TREE_TYPE (typeinit), typeinit);
9599
9600       varinits = build_tree_list ((field = TYPE_FIELDS (vardesctype)),
9601                                   nameinit);
9602       TREE_CHAIN (varinits) = build_tree_list ((field = TREE_CHAIN (field)),
9603                                                addrinit);
9604       TREE_CHAIN (TREE_CHAIN (varinits))
9605         = build_tree_list ((field = TREE_CHAIN (field)), dimsinit);
9606       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits)))
9607         = build_tree_list ((field = TREE_CHAIN (field)), typeinit);
9608
9609       varinits = build (CONSTRUCTOR, vardesctype, NULL_TREE, varinits);
9610       TREE_CONSTANT (varinits) = 1;
9611       TREE_STATIC (varinits) = 1;
9612
9613       finish_decl (var, varinits, FALSE);
9614
9615       var = ffecom_1 (ADDR_EXPR, build_pointer_type (vardesctype), var);
9616
9617       resume_momentary (yes);
9618
9619       ffesymbol_hook (s).vardesc_tree = var;
9620     }
9621
9622   return ffesymbol_hook (s).vardesc_tree;
9623 }
9624
9625 #endif
9626 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9627 static tree
9628 ffecom_vardesc_array_ (ffesymbol s)
9629 {
9630   ffebld b;
9631   tree list;
9632   tree item = NULL_TREE;
9633   tree var;
9634   int i;
9635   int yes;
9636   static int mynumber = 0;
9637
9638   for (i = 0, list = NULL_TREE, b = ffesymbol_namelist (s);
9639        b != NULL;
9640        b = ffebld_trail (b), ++i)
9641     {
9642       tree t;
9643
9644       t = ffecom_vardesc_ (ffebld_head (b));
9645
9646       if (list == NULL_TREE)
9647         list = item = build_tree_list (NULL_TREE, t);
9648       else
9649         {
9650           TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9651           item = TREE_CHAIN (item);
9652         }
9653     }
9654
9655   yes = suspend_momentary ();
9656
9657   item = build_array_type (build_pointer_type (ffecom_type_vardesc_ ()),
9658                            build_range_type (integer_type_node,
9659                                              integer_one_node,
9660                                              build_int_2 (i, 0)));
9661   list = build (CONSTRUCTOR, item, NULL_TREE, list);
9662   TREE_CONSTANT (list) = 1;
9663   TREE_STATIC (list) = 1;
9664
9665   var = ffecom_get_invented_identifier ("__g77_vardesc_array_%d", mynumber++);
9666   var = build_decl (VAR_DECL, var, item);
9667   TREE_STATIC (var) = 1;
9668   DECL_INITIAL (var) = error_mark_node;
9669   var = start_decl (var, FALSE);
9670   finish_decl (var, list, FALSE);
9671
9672   resume_momentary (yes);
9673
9674   return var;
9675 }
9676
9677 #endif
9678 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9679 static tree
9680 ffecom_vardesc_dims_ (ffesymbol s)
9681 {
9682   if (ffesymbol_dims (s) == NULL)
9683     return convert (ffecom_f2c_ptr_to_ftnlen_type_node,
9684                     integer_zero_node);
9685
9686   {
9687     ffebld b;
9688     ffebld e;
9689     tree list;
9690     tree backlist;
9691     tree item = NULL_TREE;
9692     tree var;
9693     int yes;
9694     tree numdim;
9695     tree numelem;
9696     tree baseoff = NULL_TREE;
9697     static int mynumber = 0;
9698
9699     numdim = build_int_2 ((int) ffesymbol_rank (s), 0);
9700     TREE_TYPE (numdim) = ffecom_f2c_ftnlen_type_node;
9701
9702     numelem = ffecom_expr (ffesymbol_arraysize (s));
9703     TREE_TYPE (numelem) = ffecom_f2c_ftnlen_type_node;
9704
9705     list = NULL_TREE;
9706     backlist = NULL_TREE;
9707     for (b = ffesymbol_dims (s), e = ffesymbol_extents (s);
9708          b != NULL;
9709          b = ffebld_trail (b), e = ffebld_trail (e))
9710       {
9711         tree t;
9712         tree low;
9713         tree back;
9714
9715         if (ffebld_trail (b) == NULL)
9716           t = NULL_TREE;
9717         else
9718           {
9719             t = convert (ffecom_f2c_ftnlen_type_node,
9720                          ffecom_expr (ffebld_head (e)));
9721
9722             if (list == NULL_TREE)
9723               list = item = build_tree_list (NULL_TREE, t);
9724             else
9725               {
9726                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9727                 item = TREE_CHAIN (item);
9728               }
9729           }
9730
9731         if (ffebld_left (ffebld_head (b)) == NULL)
9732           low = ffecom_integer_one_node;
9733         else
9734           low = ffecom_expr (ffebld_left (ffebld_head (b)));
9735         low = convert (ffecom_f2c_ftnlen_type_node, low);
9736
9737         back = build_tree_list (low, t);
9738         TREE_CHAIN (back) = backlist;
9739         backlist = back;
9740       }
9741
9742     for (item = backlist; item != NULL_TREE; item = TREE_CHAIN (item))
9743       {
9744         if (TREE_VALUE (item) == NULL_TREE)
9745           baseoff = TREE_PURPOSE (item);
9746         else
9747           baseoff = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
9748                               TREE_PURPOSE (item),
9749                               ffecom_2 (MULT_EXPR,
9750                                         ffecom_f2c_ftnlen_type_node,
9751                                         TREE_VALUE (item),
9752                                         baseoff));
9753       }
9754
9755     /* backlist now dead, along with all TREE_PURPOSEs on it.  */
9756
9757     baseoff = build_tree_list (NULL_TREE, baseoff);
9758     TREE_CHAIN (baseoff) = list;
9759
9760     numelem = build_tree_list (NULL_TREE, numelem);
9761     TREE_CHAIN (numelem) = baseoff;
9762
9763     numdim = build_tree_list (NULL_TREE, numdim);
9764     TREE_CHAIN (numdim) = numelem;
9765
9766     yes = suspend_momentary ();
9767
9768     item = build_array_type (ffecom_f2c_ftnlen_type_node,
9769                              build_range_type (integer_type_node,
9770                                                integer_zero_node,
9771                                                build_int_2
9772                                                ((int) ffesymbol_rank (s)
9773                                                 + 2, 0)));
9774     list = build (CONSTRUCTOR, item, NULL_TREE, numdim);
9775     TREE_CONSTANT (list) = 1;
9776     TREE_STATIC (list) = 1;
9777
9778     var = ffecom_get_invented_identifier ("__g77_dims_%d", mynumber++);
9779     var = build_decl (VAR_DECL, var, item);
9780     TREE_STATIC (var) = 1;
9781     DECL_INITIAL (var) = error_mark_node;
9782     var = start_decl (var, FALSE);
9783     finish_decl (var, list, FALSE);
9784
9785     var = ffecom_1 (ADDR_EXPR, build_pointer_type (item), var);
9786
9787     resume_momentary (yes);
9788
9789     return var;
9790   }
9791 }
9792
9793 #endif
9794 /* Essentially does a "fold (build1 (code, type, node))" while checking
9795    for certain housekeeping things.
9796
9797    NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
9798    ffecom_1_fn instead.  */
9799
9800 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9801 tree
9802 ffecom_1 (enum tree_code code, tree type, tree node)
9803 {
9804   tree item;
9805
9806   if ((node == error_mark_node)
9807       || (type == error_mark_node))
9808     return error_mark_node;
9809
9810   if (code == ADDR_EXPR)
9811     {
9812       if (!mark_addressable (node))
9813         assert ("can't mark_addressable this node!" == NULL);
9814     }
9815
9816   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9817     {
9818       tree realtype;
9819
9820     case REALPART_EXPR:
9821       item = build (COMPONENT_REF, type, node, TYPE_FIELDS (TREE_TYPE (node)));
9822       break;
9823
9824     case IMAGPART_EXPR:
9825       item = build (COMPONENT_REF, type, node, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node))));
9826       break;
9827
9828
9829     case NEGATE_EXPR:
9830       if (TREE_CODE (type) != RECORD_TYPE)
9831         {
9832           item = build1 (code, type, node);
9833           break;
9834         }
9835       node = ffecom_stabilize_aggregate_ (node);
9836       realtype = TREE_TYPE (TYPE_FIELDS (type));
9837       item =
9838         ffecom_2 (COMPLEX_EXPR, type,
9839                   ffecom_1 (NEGATE_EXPR, realtype,
9840                             ffecom_1 (REALPART_EXPR, realtype,
9841                                       node)),
9842                   ffecom_1 (NEGATE_EXPR, realtype,
9843                             ffecom_1 (IMAGPART_EXPR, realtype,
9844                                       node)));
9845       break;
9846
9847     default:
9848       item = build1 (code, type, node);
9849       break;
9850     }
9851
9852   if (TREE_SIDE_EFFECTS (node))
9853     TREE_SIDE_EFFECTS (item) = 1;
9854   if ((code == ADDR_EXPR) && staticp (node))
9855     TREE_CONSTANT (item) = 1;
9856   return fold (item);
9857 }
9858 #endif
9859
9860 /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
9861    handles TREE_CODE (node) == FUNCTION_DECL.  In particular,
9862    does not set TREE_ADDRESSABLE (because calling an inline
9863    function does not mean the function needs to be separately
9864    compiled).  */
9865
9866 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9867 tree
9868 ffecom_1_fn (tree node)
9869 {
9870   tree item;
9871   tree type;
9872
9873   if (node == error_mark_node)
9874     return error_mark_node;
9875
9876   type = build_type_variant (TREE_TYPE (node),
9877                              TREE_READONLY (node),
9878                              TREE_THIS_VOLATILE (node));
9879   item = build1 (ADDR_EXPR,
9880                  build_pointer_type (type), node);
9881   if (TREE_SIDE_EFFECTS (node))
9882     TREE_SIDE_EFFECTS (item) = 1;
9883   if (staticp (node))
9884     TREE_CONSTANT (item) = 1;
9885   return fold (item);
9886 }
9887 #endif
9888
9889 /* Essentially does a "fold (build (code, type, node1, node2))" while
9890    checking for certain housekeeping things.  */
9891
9892 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9893 tree
9894 ffecom_2 (enum tree_code code, tree type, tree node1,
9895           tree node2)
9896 {
9897   tree item;
9898
9899   if ((node1 == error_mark_node)
9900       || (node2 == error_mark_node)
9901       || (type == error_mark_node))
9902     return error_mark_node;
9903
9904   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9905     {
9906       tree a, b, c, d, realtype;
9907
9908     case CONJ_EXPR:
9909       assert ("no CONJ_EXPR support yet" == NULL);
9910       return error_mark_node;
9911
9912     case COMPLEX_EXPR:
9913       item = build_tree_list (TYPE_FIELDS (type), node1);
9914       TREE_CHAIN (item) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), node2);
9915       item = build (CONSTRUCTOR, type, NULL_TREE, item);
9916       break;
9917
9918     case PLUS_EXPR:
9919       if (TREE_CODE (type) != RECORD_TYPE)
9920         {
9921           item = build (code, type, node1, node2);
9922           break;
9923         }
9924       node1 = ffecom_stabilize_aggregate_ (node1);
9925       node2 = ffecom_stabilize_aggregate_ (node2);
9926       realtype = TREE_TYPE (TYPE_FIELDS (type));
9927       item =
9928         ffecom_2 (COMPLEX_EXPR, type,
9929                   ffecom_2 (PLUS_EXPR, realtype,
9930                             ffecom_1 (REALPART_EXPR, realtype,
9931                                       node1),
9932                             ffecom_1 (REALPART_EXPR, realtype,
9933                                       node2)),
9934                   ffecom_2 (PLUS_EXPR, realtype,
9935                             ffecom_1 (IMAGPART_EXPR, realtype,
9936                                       node1),
9937                             ffecom_1 (IMAGPART_EXPR, realtype,
9938                                       node2)));
9939       break;
9940
9941     case MINUS_EXPR:
9942       if (TREE_CODE (type) != RECORD_TYPE)
9943         {
9944           item = build (code, type, node1, node2);
9945           break;
9946         }
9947       node1 = ffecom_stabilize_aggregate_ (node1);
9948       node2 = ffecom_stabilize_aggregate_ (node2);
9949       realtype = TREE_TYPE (TYPE_FIELDS (type));
9950       item =
9951         ffecom_2 (COMPLEX_EXPR, type,
9952                   ffecom_2 (MINUS_EXPR, realtype,
9953                             ffecom_1 (REALPART_EXPR, realtype,
9954                                       node1),
9955                             ffecom_1 (REALPART_EXPR, realtype,
9956                                       node2)),
9957                   ffecom_2 (MINUS_EXPR, realtype,
9958                             ffecom_1 (IMAGPART_EXPR, realtype,
9959                                       node1),
9960                             ffecom_1 (IMAGPART_EXPR, realtype,
9961                                       node2)));
9962       break;
9963
9964     case MULT_EXPR:
9965       if (TREE_CODE (type) != RECORD_TYPE)
9966         {
9967           item = build (code, type, node1, node2);
9968           break;
9969         }
9970       node1 = ffecom_stabilize_aggregate_ (node1);
9971       node2 = ffecom_stabilize_aggregate_ (node2);
9972       realtype = TREE_TYPE (TYPE_FIELDS (type));
9973       a = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9974                                node1));
9975       b = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9976                                node1));
9977       c = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9978                                node2));
9979       d = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9980                                node2));
9981       item =
9982         ffecom_2 (COMPLEX_EXPR, type,
9983                   ffecom_2 (MINUS_EXPR, realtype,
9984                             ffecom_2 (MULT_EXPR, realtype,
9985                                       a,
9986                                       c),
9987                             ffecom_2 (MULT_EXPR, realtype,
9988                                       b,
9989                                       d)),
9990                   ffecom_2 (PLUS_EXPR, realtype,
9991                             ffecom_2 (MULT_EXPR, realtype,
9992                                       a,
9993                                       d),
9994                             ffecom_2 (MULT_EXPR, realtype,
9995                                       c,
9996                                       b)));
9997       break;
9998
9999     case EQ_EXPR:
10000       if ((TREE_CODE (node1) != RECORD_TYPE)
10001           && (TREE_CODE (node2) != RECORD_TYPE))
10002         {
10003           item = build (code, type, node1, node2);
10004           break;
10005         }
10006       assert (TREE_CODE (node1) == RECORD_TYPE);
10007       assert (TREE_CODE (node2) == RECORD_TYPE);
10008       node1 = ffecom_stabilize_aggregate_ (node1);
10009       node2 = ffecom_stabilize_aggregate_ (node2);
10010       realtype = TREE_TYPE (TYPE_FIELDS (type));
10011       item =
10012         ffecom_2 (TRUTH_ANDIF_EXPR, type,
10013                   ffecom_2 (code, type,
10014                             ffecom_1 (REALPART_EXPR, realtype,
10015                                       node1),
10016                             ffecom_1 (REALPART_EXPR, realtype,
10017                                       node2)),
10018                   ffecom_2 (code, type,
10019                             ffecom_1 (IMAGPART_EXPR, realtype,
10020                                       node1),
10021                             ffecom_1 (IMAGPART_EXPR, realtype,
10022                                       node2)));
10023       break;
10024
10025     case NE_EXPR:
10026       if ((TREE_CODE (node1) != RECORD_TYPE)
10027           && (TREE_CODE (node2) != RECORD_TYPE))
10028         {
10029           item = build (code, type, node1, node2);
10030           break;
10031         }
10032       assert (TREE_CODE (node1) == RECORD_TYPE);
10033       assert (TREE_CODE (node2) == RECORD_TYPE);
10034       node1 = ffecom_stabilize_aggregate_ (node1);
10035       node2 = ffecom_stabilize_aggregate_ (node2);
10036       realtype = TREE_TYPE (TYPE_FIELDS (type));
10037       item =
10038         ffecom_2 (TRUTH_ORIF_EXPR, type,
10039                   ffecom_2 (code, type,
10040                             ffecom_1 (REALPART_EXPR, realtype,
10041                                       node1),
10042                             ffecom_1 (REALPART_EXPR, realtype,
10043                                       node2)),
10044                   ffecom_2 (code, type,
10045                             ffecom_1 (IMAGPART_EXPR, realtype,
10046                                       node1),
10047                             ffecom_1 (IMAGPART_EXPR, realtype,
10048                                       node2)));
10049       break;
10050
10051     default:
10052       item = build (code, type, node1, node2);
10053       break;
10054     }
10055
10056   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2))
10057     TREE_SIDE_EFFECTS (item) = 1;
10058   return fold (item);
10059 }
10060
10061 #endif
10062 /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
10063
10064    ffesymbol s;  // the ENTRY point itself
10065    if (ffecom_2pass_advise_entrypoint(s))
10066        // the ENTRY point has been accepted
10067
10068    Does whatever compiler needs to do when it learns about the entrypoint,
10069    like determine the return type of the master function, count the
10070    number of entrypoints, etc.  Returns FALSE if the return type is
10071    not compatible with the return type(s) of other entrypoint(s).
10072
10073    NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
10074    later (after _finish_progunit) be called with the same entrypoint(s)
10075    as passed to this fn for which TRUE was returned.
10076
10077    03-Jan-92  JCB  2.0
10078       Return FALSE if the return type conflicts with previous entrypoints.  */
10079
10080 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10081 bool
10082 ffecom_2pass_advise_entrypoint (ffesymbol entry)
10083 {
10084   ffebld list;                  /* opITEM. */
10085   ffebld mlist;                 /* opITEM. */
10086   ffebld plist;                 /* opITEM. */
10087   ffebld arg;                   /* ffebld_head(opITEM). */
10088   ffebld item;                  /* opITEM. */
10089   ffesymbol s;                  /* ffebld_symter(arg). */
10090   ffeinfoBasictype bt = ffesymbol_basictype (entry);
10091   ffeinfoKindtype kt = ffesymbol_kindtype (entry);
10092   ffetargetCharacterSize size = ffesymbol_size (entry);
10093   bool ok;
10094
10095   if (ffecom_num_entrypoints_ == 0)
10096     {                           /* First entrypoint, make list of main
10097                                    arglist's dummies. */
10098       assert (ffecom_primary_entry_ != NULL);
10099
10100       ffecom_master_bt_ = ffesymbol_basictype (ffecom_primary_entry_);
10101       ffecom_master_kt_ = ffesymbol_kindtype (ffecom_primary_entry_);
10102       ffecom_master_size_ = ffesymbol_size (ffecom_primary_entry_);
10103
10104       for (plist = NULL, list = ffesymbol_dummyargs (ffecom_primary_entry_);
10105            list != NULL;
10106            list = ffebld_trail (list))
10107         {
10108           arg = ffebld_head (list);
10109           if (ffebld_op (arg) != FFEBLD_opSYMTER)
10110             continue;           /* Alternate return or some such thing. */
10111           item = ffebld_new_item (arg, NULL);
10112           if (plist == NULL)
10113             ffecom_master_arglist_ = item;
10114           else
10115             ffebld_set_trail (plist, item);
10116           plist = item;
10117         }
10118     }
10119
10120   /* If necessary, scan entry arglist for alternate returns.  Do this scan
10121      apparently redundantly (it's done below to UNIONize the arglists) so
10122      that we don't complain about RETURN 1 if an offending ENTRY is the only
10123      one with an alternate return.  */
10124
10125   if (!ffecom_is_altreturning_)
10126     {
10127       for (list = ffesymbol_dummyargs (entry);
10128            list != NULL;
10129            list = ffebld_trail (list))
10130         {
10131           arg = ffebld_head (list);
10132           if (ffebld_op (arg) == FFEBLD_opSTAR)
10133             {
10134               ffecom_is_altreturning_ = TRUE;
10135               break;
10136             }
10137         }
10138     }
10139
10140   /* Now check type compatibility. */
10141
10142   switch (ffecom_master_bt_)
10143     {
10144     case FFEINFO_basictypeNONE:
10145       ok = (bt != FFEINFO_basictypeCHARACTER);
10146       break;
10147
10148     case FFEINFO_basictypeCHARACTER:
10149       ok
10150         = (bt == FFEINFO_basictypeCHARACTER)
10151         && (kt == ffecom_master_kt_)
10152         && (size == ffecom_master_size_);
10153       break;
10154
10155     case FFEINFO_basictypeANY:
10156       return FALSE;             /* Just don't bother. */
10157
10158     default:
10159       if (bt == FFEINFO_basictypeCHARACTER)
10160         {
10161           ok = FALSE;
10162           break;
10163         }
10164       ok = TRUE;
10165       if ((bt != ffecom_master_bt_) || (kt != ffecom_master_kt_))
10166         {
10167           ffecom_master_bt_ = FFEINFO_basictypeNONE;
10168           ffecom_master_kt_ = FFEINFO_kindtypeNONE;
10169         }
10170       break;
10171     }
10172
10173   if (!ok)
10174     {
10175       ffebad_start (FFEBAD_ENTRY_CONFLICTS);
10176       ffest_ffebad_here_current_stmt (0);
10177       ffebad_finish ();
10178       return FALSE;             /* Can't handle entrypoint. */
10179     }
10180
10181   /* Entrypoint type compatible with previous types. */
10182
10183   ++ffecom_num_entrypoints_;
10184
10185   /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
10186
10187   for (list = ffesymbol_dummyargs (entry);
10188        list != NULL;
10189        list = ffebld_trail (list))
10190     {
10191       arg = ffebld_head (list);
10192       if (ffebld_op (arg) != FFEBLD_opSYMTER)
10193         continue;               /* Alternate return or some such thing. */
10194       s = ffebld_symter (arg);
10195       for (plist = NULL, mlist = ffecom_master_arglist_;
10196            mlist != NULL;
10197            plist = mlist, mlist = ffebld_trail (mlist))
10198         {                       /* plist points to previous item for easy
10199                                    appending of arg. */
10200           if (ffebld_symter (ffebld_head (mlist)) == s)
10201             break;              /* Already have this arg in the master list. */
10202         }
10203       if (mlist != NULL)
10204         continue;               /* Already have this arg in the master list. */
10205
10206       /* Append this arg to the master list. */
10207
10208       item = ffebld_new_item (arg, NULL);
10209       if (plist == NULL)
10210         ffecom_master_arglist_ = item;
10211       else
10212         ffebld_set_trail (plist, item);
10213     }
10214
10215   return TRUE;
10216 }
10217
10218 #endif
10219 /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
10220
10221    ffesymbol s;  // the ENTRY point itself
10222    ffecom_2pass_do_entrypoint(s);
10223
10224    Does whatever compiler needs to do to make the entrypoint actually
10225    happen.  Must be called for each entrypoint after
10226    ffecom_finish_progunit is called.  */
10227
10228 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10229 void
10230 ffecom_2pass_do_entrypoint (ffesymbol entry)
10231 {
10232   static int mfn_num = 0;
10233   static int ent_num;
10234
10235   if (mfn_num != ffecom_num_fns_)
10236     {                           /* First entrypoint for this program unit. */
10237       ent_num = 1;
10238       mfn_num = ffecom_num_fns_;
10239       ffecom_do_entry_ (ffecom_primary_entry_, 0);
10240     }
10241   else
10242     ++ent_num;
10243
10244   --ffecom_num_entrypoints_;
10245
10246   ffecom_do_entry_ (entry, ent_num);
10247 }
10248
10249 #endif
10250
10251 /* Essentially does a "fold (build (code, type, node1, node2))" while
10252    checking for certain housekeeping things.  Always sets
10253    TREE_SIDE_EFFECTS.  */
10254
10255 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10256 tree
10257 ffecom_2s (enum tree_code code, tree type, tree node1,
10258            tree node2)
10259 {
10260   tree item;
10261
10262   if ((node1 == error_mark_node)
10263       || (node2 == error_mark_node)
10264       || (type == error_mark_node))
10265     return error_mark_node;
10266
10267   item = build (code, type, node1, node2);
10268   TREE_SIDE_EFFECTS (item) = 1;
10269   return fold (item);
10270 }
10271
10272 #endif
10273 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10274    checking for certain housekeeping things.  */
10275
10276 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10277 tree
10278 ffecom_3 (enum tree_code code, tree type, tree node1,
10279           tree node2, tree node3)
10280 {
10281   tree item;
10282
10283   if ((node1 == error_mark_node)
10284       || (node2 == error_mark_node)
10285       || (node3 == error_mark_node)
10286       || (type == error_mark_node))
10287     return error_mark_node;
10288
10289   item = build (code, type, node1, node2, node3);
10290   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2)
10291       || (node3 != NULL_TREE && TREE_SIDE_EFFECTS (node3)))
10292     TREE_SIDE_EFFECTS (item) = 1;
10293   return fold (item);
10294 }
10295
10296 #endif
10297 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10298    checking for certain housekeeping things.  Always sets
10299    TREE_SIDE_EFFECTS.  */
10300
10301 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10302 tree
10303 ffecom_3s (enum tree_code code, tree type, tree node1,
10304            tree node2, tree node3)
10305 {
10306   tree item;
10307
10308   if ((node1 == error_mark_node)
10309       || (node2 == error_mark_node)
10310       || (node3 == error_mark_node)
10311       || (type == error_mark_node))
10312     return error_mark_node;
10313
10314   item = build (code, type, node1, node2, node3);
10315   TREE_SIDE_EFFECTS (item) = 1;
10316   return fold (item);
10317 }
10318
10319 #endif
10320
10321 /* ffecom_arg_expr -- Transform argument expr into gcc tree
10322
10323    See use by ffecom_list_expr.
10324
10325    If expression is NULL, returns an integer zero tree.  If it is not
10326    a CHARACTER expression, returns whatever ffecom_expr
10327    returns and sets the length return value to NULL_TREE.  Otherwise
10328    generates code to evaluate the character expression, returns the proper
10329    pointer to the result, but does NOT set the length return value to a tree
10330    that specifies the length of the result.  (In other words, the length
10331    variable is always set to NULL_TREE, because a length is never passed.)
10332
10333    21-Dec-91  JCB  1.1
10334       Don't set returned length, since nobody needs it (yet; someday if
10335       we allow CHARACTER*(*) dummies to statement functions, we'll need
10336       it).  */
10337
10338 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10339 tree
10340 ffecom_arg_expr (ffebld expr, tree *length)
10341 {
10342   tree ign;
10343
10344   *length = NULL_TREE;
10345
10346   if (expr == NULL)
10347     return integer_zero_node;
10348
10349   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10350     return ffecom_expr (expr);
10351
10352   return ffecom_arg_ptr_to_expr (expr, &ign);
10353 }
10354
10355 #endif
10356 /* Transform expression into constant argument-pointer-to-expression tree.
10357
10358    If the expression can be transformed into a argument-pointer-to-expression
10359    tree that is constant, that is done, and the tree returned.  Else
10360    NULL_TREE is returned.
10361
10362    That way, a caller can attempt to provide compile-time initialization
10363    of a variable and, if that fails, *then* choose to start a new block
10364    and resort to using temporaries, as appropriate.  */
10365
10366 tree
10367 ffecom_arg_ptr_to_const_expr (ffebld expr, tree *length)
10368 {
10369   if (! expr)
10370     return integer_zero_node;
10371
10372   if (ffebld_op (expr) == FFEBLD_opANY)
10373     {
10374       if (length)
10375         *length = error_mark_node;
10376       return error_mark_node;
10377     }
10378
10379   if (ffebld_arity (expr) == 0
10380       && (ffebld_op (expr) != FFEBLD_opSYMTER
10381           || ffebld_where (expr) == FFEINFO_whereCOMMON
10382           || ffebld_where (expr) == FFEINFO_whereGLOBAL
10383           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10384     {
10385       tree t;
10386
10387       t = ffecom_arg_ptr_to_expr (expr, length);
10388       assert (TREE_CONSTANT (t));
10389       assert (! length || TREE_CONSTANT (*length));
10390       return t;
10391     }
10392
10393   if (length
10394       && ffebld_size (expr) != FFETARGET_charactersizeNONE)
10395     *length = build_int_2 (ffebld_size (expr), 0);
10396   else if (length)
10397     *length = NULL_TREE;
10398   return NULL_TREE;
10399 }
10400
10401 /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
10402
10403    See use by ffecom_list_ptr_to_expr.
10404
10405    If expression is NULL, returns an integer zero tree.  If it is not
10406    a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10407    returns and sets the length return value to NULL_TREE.  Otherwise
10408    generates code to evaluate the character expression, returns the proper
10409    pointer to the result, AND sets the length return value to a tree that
10410    specifies the length of the result.
10411
10412    If the length argument is NULL, this is a slightly special
10413    case of building a FORMAT expression, that is, an expression that
10414    will be used at run time without regard to length.  For the current
10415    implementation, which uses the libf2c library, this means it is nice
10416    to append a null byte to the end of the expression, where feasible,
10417    to make sure any diagnostic about the FORMAT string terminates at
10418    some useful point.
10419
10420    For now, treat %REF(char-expr) as the same as char-expr with a NULL
10421    length argument.  This might even be seen as a feature, if a null
10422    byte can always be appended.  */
10423
10424 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10425 tree
10426 ffecom_arg_ptr_to_expr (ffebld expr, tree *length)
10427 {
10428   tree item;
10429   tree ign_length;
10430   ffecomConcatList_ catlist;
10431
10432   if (length != NULL)
10433     *length = NULL_TREE;
10434
10435   if (expr == NULL)
10436     return integer_zero_node;
10437
10438   switch (ffebld_op (expr))
10439     {
10440     case FFEBLD_opPERCENT_VAL:
10441       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10442         return ffecom_expr (ffebld_left (expr));
10443       {
10444         tree temp_exp;
10445         tree temp_length;
10446
10447         temp_exp = ffecom_arg_ptr_to_expr (ffebld_left (expr), &temp_length);
10448         if (temp_exp == error_mark_node)
10449           return error_mark_node;
10450
10451         return ffecom_1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (temp_exp)),
10452                          temp_exp);
10453       }
10454
10455     case FFEBLD_opPERCENT_REF:
10456       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10457         return ffecom_ptr_to_expr (ffebld_left (expr));
10458       if (length != NULL)
10459         {
10460           ign_length = NULL_TREE;
10461           length = &ign_length;
10462         }
10463       expr = ffebld_left (expr);
10464       break;
10465
10466     case FFEBLD_opPERCENT_DESCR:
10467       switch (ffeinfo_basictype (ffebld_info (expr)))
10468         {
10469 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10470         case FFEINFO_basictypeHOLLERITH:
10471 #endif
10472         case FFEINFO_basictypeCHARACTER:
10473           break;                /* Passed by descriptor anyway. */
10474
10475         default:
10476           item = ffecom_ptr_to_expr (expr);
10477           if (item != error_mark_node)
10478             *length = TYPE_SIZE (TREE_TYPE (TREE_TYPE (item)));
10479           break;
10480         }
10481       break;
10482
10483     default:
10484       break;
10485     }
10486
10487 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10488   if ((ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeHOLLERITH)
10489       && (length != NULL))
10490     {                           /* Pass Hollerith by descriptor. */
10491       ffetargetHollerith h;
10492
10493       assert (ffebld_op (expr) == FFEBLD_opCONTER);
10494       h = ffebld_cu_val_hollerith (ffebld_constant_union
10495                                    (ffebld_conter (expr)));
10496       *length
10497         = build_int_2 (h.length, 0);
10498       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10499     }
10500 #endif
10501
10502   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10503     return ffecom_ptr_to_expr (expr);
10504
10505   assert (ffeinfo_kindtype (ffebld_info (expr))
10506           == FFEINFO_kindtypeCHARACTER1);
10507
10508   while (ffebld_op (expr) == FFEBLD_opPAREN)
10509     expr = ffebld_left (expr);
10510
10511   catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
10512   switch (ffecom_concat_list_count_ (catlist))
10513     {
10514     case 0:                     /* Shouldn't happen, but in case it does... */
10515       if (length != NULL)
10516         {
10517           *length = ffecom_f2c_ftnlen_zero_node;
10518           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10519         }
10520       ffecom_concat_list_kill_ (catlist);
10521       return null_pointer_node;
10522
10523     case 1:                     /* The (fairly) easy case. */
10524       if (length == NULL)
10525         ffecom_char_args_with_null_ (&item, &ign_length,
10526                                      ffecom_concat_list_expr_ (catlist, 0));
10527       else
10528         ffecom_char_args_ (&item, length,
10529                            ffecom_concat_list_expr_ (catlist, 0));
10530       ffecom_concat_list_kill_ (catlist);
10531       assert (item != NULL_TREE);
10532       return item;
10533
10534     default:                    /* Must actually concatenate things. */
10535       break;
10536     }
10537
10538   {
10539     int count = ffecom_concat_list_count_ (catlist);
10540     int i;
10541     tree lengths;
10542     tree items;
10543     tree length_array;
10544     tree item_array;
10545     tree citem;
10546     tree clength;
10547     tree temporary;
10548     tree num;
10549     tree known_length;
10550     ffetargetCharacterSize sz;
10551
10552     sz = ffecom_concat_list_maxlen_ (catlist);
10553     /* ~~Kludge! */
10554     assert (sz != FFETARGET_charactersizeNONE);
10555
10556 #ifdef HOHO
10557     length_array
10558       = lengths
10559       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
10560                              FFETARGET_charactersizeNONE, count, TRUE);
10561     item_array
10562       = items
10563       = ffecom_push_tempvar (ffecom_f2c_address_type_node,
10564                              FFETARGET_charactersizeNONE, count, TRUE);
10565     temporary = ffecom_push_tempvar (char_type_node,
10566                                      sz, -1, TRUE);
10567 #else
10568     {
10569       tree hook;
10570
10571       hook = ffebld_nonter_hook (expr);
10572       assert (hook);
10573       assert (TREE_CODE (hook) == TREE_VEC);
10574       assert (TREE_VEC_LENGTH (hook) == 3);
10575       length_array = lengths = TREE_VEC_ELT (hook, 0);
10576       item_array = items = TREE_VEC_ELT (hook, 1);
10577       temporary = TREE_VEC_ELT (hook, 2);
10578     }
10579 #endif
10580
10581     known_length = ffecom_f2c_ftnlen_zero_node;
10582
10583     for (i = 0; i < count; ++i)
10584       {
10585         if ((i == count)
10586             && (length == NULL))
10587           ffecom_char_args_with_null_ (&citem, &clength,
10588                                        ffecom_concat_list_expr_ (catlist, i));
10589         else
10590           ffecom_char_args_ (&citem, &clength,
10591                              ffecom_concat_list_expr_ (catlist, i));
10592         if ((citem == error_mark_node)
10593             || (clength == error_mark_node))
10594           {
10595             ffecom_concat_list_kill_ (catlist);
10596             *length = error_mark_node;
10597             return error_mark_node;
10598           }
10599
10600         items
10601           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
10602                       ffecom_modify (void_type_node,
10603                                      ffecom_2 (ARRAY_REF,
10604                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
10605                                                item_array,
10606                                                build_int_2 (i, 0)),
10607                                      citem),
10608                       items);
10609         clength = ffecom_save_tree (clength);
10610         if (length != NULL)
10611           known_length
10612             = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
10613                         known_length,
10614                         clength);
10615         lengths
10616           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
10617                       ffecom_modify (void_type_node,
10618                                      ffecom_2 (ARRAY_REF,
10619                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
10620                                                length_array,
10621                                                build_int_2 (i, 0)),
10622                                      clength),
10623                       lengths);
10624       }
10625
10626     temporary = ffecom_1 (ADDR_EXPR,
10627                           build_pointer_type (TREE_TYPE (temporary)),
10628                           temporary);
10629
10630     item = build_tree_list (NULL_TREE, temporary);
10631     TREE_CHAIN (item)
10632       = build_tree_list (NULL_TREE,
10633                          ffecom_1 (ADDR_EXPR,
10634                                    build_pointer_type (TREE_TYPE (items)),
10635                                    items));
10636     TREE_CHAIN (TREE_CHAIN (item))
10637       = build_tree_list (NULL_TREE,
10638                          ffecom_1 (ADDR_EXPR,
10639                                    build_pointer_type (TREE_TYPE (lengths)),
10640                                    lengths));
10641     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
10642       = build_tree_list
10643         (NULL_TREE,
10644          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
10645                    convert (ffecom_f2c_ftnlen_type_node,
10646                             build_int_2 (count, 0))));
10647     num = build_int_2 (sz, 0);
10648     TREE_TYPE (num) = ffecom_f2c_ftnlen_type_node;
10649     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item))))
10650       = build_tree_list (NULL_TREE, num);
10651
10652     item = ffecom_call_gfrt (FFECOM_gfrtCAT, item, NULL_TREE);
10653     TREE_SIDE_EFFECTS (item) = 1;
10654     item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (temporary),
10655                      item,
10656                      temporary);
10657
10658     if (length != NULL)
10659       *length = known_length;
10660   }
10661
10662   ffecom_concat_list_kill_ (catlist);
10663   assert (item != NULL_TREE);
10664   return item;
10665 }
10666
10667 #endif
10668 /* Generate call to run-time function.
10669
10670    The first arg is the GNU Fortran Run-Time function index, the second
10671    arg is the list of arguments to pass to it.  Returned is the expression
10672    (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
10673    result (which may be void).  */
10674
10675 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10676 tree
10677 ffecom_call_gfrt (ffecomGfrt ix, tree args, tree hook)
10678 {
10679   return ffecom_call_ (ffecom_gfrt_tree_ (ix),
10680                        ffecom_gfrt_kindtype (ix),
10681                        ffe_is_f2c_library () && ffecom_gfrt_complex_[ix],
10682                        NULL_TREE, args, NULL_TREE, NULL,
10683                        NULL, NULL_TREE, TRUE, hook);
10684 }
10685 #endif
10686
10687 /* Transform constant-union to tree.  */
10688
10689 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10690 tree
10691 ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt,
10692                       ffeinfoKindtype kt, tree tree_type)
10693 {
10694   tree item;
10695
10696   switch (bt)
10697     {
10698     case FFEINFO_basictypeINTEGER:
10699       {
10700         int val;
10701
10702         switch (kt)
10703           {
10704 #if FFETARGET_okINTEGER1
10705           case FFEINFO_kindtypeINTEGER1:
10706             val = ffebld_cu_val_integer1 (*cu);
10707             break;
10708 #endif
10709
10710 #if FFETARGET_okINTEGER2
10711           case FFEINFO_kindtypeINTEGER2:
10712             val = ffebld_cu_val_integer2 (*cu);
10713             break;
10714 #endif
10715
10716 #if FFETARGET_okINTEGER3
10717           case FFEINFO_kindtypeINTEGER3:
10718             val = ffebld_cu_val_integer3 (*cu);
10719             break;
10720 #endif
10721
10722 #if FFETARGET_okINTEGER4
10723           case FFEINFO_kindtypeINTEGER4:
10724             val = ffebld_cu_val_integer4 (*cu);
10725             break;
10726 #endif
10727
10728           default:
10729             assert ("bad INTEGER constant kind type" == NULL);
10730             /* Fall through. */
10731           case FFEINFO_kindtypeANY:
10732             return error_mark_node;
10733           }
10734         item = build_int_2 (val, (val < 0) ? -1 : 0);
10735         TREE_TYPE (item) = tree_type;
10736       }
10737       break;
10738
10739     case FFEINFO_basictypeLOGICAL:
10740       {
10741         int val;
10742
10743         switch (kt)
10744           {
10745 #if FFETARGET_okLOGICAL1
10746           case FFEINFO_kindtypeLOGICAL1:
10747             val = ffebld_cu_val_logical1 (*cu);
10748             break;
10749 #endif
10750
10751 #if FFETARGET_okLOGICAL2
10752           case FFEINFO_kindtypeLOGICAL2:
10753             val = ffebld_cu_val_logical2 (*cu);
10754             break;
10755 #endif
10756
10757 #if FFETARGET_okLOGICAL3
10758           case FFEINFO_kindtypeLOGICAL3:
10759             val = ffebld_cu_val_logical3 (*cu);
10760             break;
10761 #endif
10762
10763 #if FFETARGET_okLOGICAL4
10764           case FFEINFO_kindtypeLOGICAL4:
10765             val = ffebld_cu_val_logical4 (*cu);
10766             break;
10767 #endif
10768
10769           default:
10770             assert ("bad LOGICAL constant kind type" == NULL);
10771             /* Fall through. */
10772           case FFEINFO_kindtypeANY:
10773             return error_mark_node;
10774           }
10775         item = build_int_2 (val, (val < 0) ? -1 : 0);
10776         TREE_TYPE (item) = tree_type;
10777       }
10778       break;
10779
10780     case FFEINFO_basictypeREAL:
10781       {
10782         REAL_VALUE_TYPE val;
10783
10784         switch (kt)
10785           {
10786 #if FFETARGET_okREAL1
10787           case FFEINFO_kindtypeREAL1:
10788             val = ffetarget_value_real1 (ffebld_cu_val_real1 (*cu));
10789             break;
10790 #endif
10791
10792 #if FFETARGET_okREAL2
10793           case FFEINFO_kindtypeREAL2:
10794             val = ffetarget_value_real2 (ffebld_cu_val_real2 (*cu));
10795             break;
10796 #endif
10797
10798 #if FFETARGET_okREAL3
10799           case FFEINFO_kindtypeREAL3:
10800             val = ffetarget_value_real3 (ffebld_cu_val_real3 (*cu));
10801             break;
10802 #endif
10803
10804 #if FFETARGET_okREAL4
10805           case FFEINFO_kindtypeREAL4:
10806             val = ffetarget_value_real4 (ffebld_cu_val_real4 (*cu));
10807             break;
10808 #endif
10809
10810           default:
10811             assert ("bad REAL constant kind type" == NULL);
10812             /* Fall through. */
10813           case FFEINFO_kindtypeANY:
10814             return error_mark_node;
10815           }
10816         item = build_real (tree_type, val);
10817       }
10818       break;
10819
10820     case FFEINFO_basictypeCOMPLEX:
10821       {
10822         REAL_VALUE_TYPE real;
10823         REAL_VALUE_TYPE imag;
10824         tree el_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
10825
10826         switch (kt)
10827           {
10828 #if FFETARGET_okCOMPLEX1
10829           case FFEINFO_kindtypeREAL1:
10830             real = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).real);
10831             imag = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).imaginary);
10832             break;
10833 #endif
10834
10835 #if FFETARGET_okCOMPLEX2
10836           case FFEINFO_kindtypeREAL2:
10837             real = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).real);
10838             imag = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).imaginary);
10839             break;
10840 #endif
10841
10842 #if FFETARGET_okCOMPLEX3
10843           case FFEINFO_kindtypeREAL3:
10844             real = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).real);
10845             imag = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).imaginary);
10846             break;
10847 #endif
10848
10849 #if FFETARGET_okCOMPLEX4
10850           case FFEINFO_kindtypeREAL4:
10851             real = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).real);
10852             imag = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).imaginary);
10853             break;
10854 #endif
10855
10856           default:
10857             assert ("bad REAL constant kind type" == NULL);
10858             /* Fall through. */
10859           case FFEINFO_kindtypeANY:
10860             return error_mark_node;
10861           }
10862         item = ffecom_build_complex_constant_ (tree_type,
10863                                                build_real (el_type, real),
10864                                                build_real (el_type, imag));
10865       }
10866       break;
10867
10868     case FFEINFO_basictypeCHARACTER:
10869       {                         /* Happens only in DATA and similar contexts. */
10870         ffetargetCharacter1 val;
10871
10872         switch (kt)
10873           {
10874 #if FFETARGET_okCHARACTER1
10875           case FFEINFO_kindtypeLOGICAL1:
10876             val = ffebld_cu_val_character1 (*cu);
10877             break;
10878 #endif
10879
10880           default:
10881             assert ("bad CHARACTER constant kind type" == NULL);
10882             /* Fall through. */
10883           case FFEINFO_kindtypeANY:
10884             return error_mark_node;
10885           }
10886         item = build_string (ffetarget_length_character1 (val),
10887                              ffetarget_text_character1 (val));
10888         TREE_TYPE (item)
10889           = build_type_variant (build_array_type (char_type_node,
10890                                                   build_range_type
10891                                                   (integer_type_node,
10892                                                    integer_one_node,
10893                                                    build_int_2
10894                                                 (ffetarget_length_character1
10895                                                  (val), 0))),
10896                                 1, 0);
10897       }
10898       break;
10899
10900     case FFEINFO_basictypeHOLLERITH:
10901       {
10902         ffetargetHollerith h;
10903
10904         h = ffebld_cu_val_hollerith (*cu);
10905
10906         /* If not at least as wide as default INTEGER, widen it.  */
10907         if (h.length >= FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE)
10908           item = build_string (h.length, h.text);
10909         else
10910           {
10911             char str[FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE];
10912
10913             memcpy (str, h.text, h.length);
10914             memset (&str[h.length], ' ',
10915                     FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE
10916                     - h.length);
10917             item = build_string (FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE,
10918                                  str);
10919           }
10920         TREE_TYPE (item)
10921           = build_type_variant (build_array_type (char_type_node,
10922                                                   build_range_type
10923                                                   (integer_type_node,
10924                                                    integer_one_node,
10925                                                    build_int_2
10926                                                    (h.length, 0))),
10927                                 1, 0);
10928       }
10929       break;
10930
10931     case FFEINFO_basictypeTYPELESS:
10932       {
10933         ffetargetInteger1 ival;
10934         ffetargetTypeless tless;
10935         ffebad error;
10936
10937         tless = ffebld_cu_val_typeless (*cu);
10938         error = ffetarget_convert_integer1_typeless (&ival, tless);
10939         assert (error == FFEBAD);
10940
10941         item = build_int_2 ((int) ival, 0);
10942       }
10943       break;
10944
10945     default:
10946       assert ("not yet on constant type" == NULL);
10947       /* Fall through. */
10948     case FFEINFO_basictypeANY:
10949       return error_mark_node;
10950     }
10951
10952   TREE_CONSTANT (item) = 1;
10953
10954   return item;
10955 }
10956
10957 #endif
10958
10959 /* Transform expression into constant tree.
10960
10961    If the expression can be transformed into a tree that is constant,
10962    that is done, and the tree returned.  Else NULL_TREE is returned.
10963
10964    That way, a caller can attempt to provide compile-time initialization
10965    of a variable and, if that fails, *then* choose to start a new block
10966    and resort to using temporaries, as appropriate.  */
10967
10968 tree
10969 ffecom_const_expr (ffebld expr)
10970 {
10971   if (! expr)
10972     return integer_zero_node;
10973
10974   if (ffebld_op (expr) == FFEBLD_opANY)
10975     return error_mark_node;
10976
10977   if (ffebld_arity (expr) == 0
10978       && (ffebld_op (expr) != FFEBLD_opSYMTER
10979 #if NEWCOMMON
10980           /* ~~Enable once common/equivalence is handled properly?  */
10981           || ffebld_where (expr) == FFEINFO_whereCOMMON
10982 #endif
10983           || ffebld_where (expr) == FFEINFO_whereGLOBAL
10984           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10985     {
10986       tree t;
10987
10988       t = ffecom_expr (expr);
10989       assert (TREE_CONSTANT (t));
10990       return t;
10991     }
10992
10993   return NULL_TREE;
10994 }
10995
10996 /* Handy way to make a field in a struct/union.  */
10997
10998 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10999 tree
11000 ffecom_decl_field (tree context, tree prevfield,
11001                    const char *name, tree type)
11002 {
11003   tree field;
11004
11005   field = build_decl (FIELD_DECL, get_identifier (name), type);
11006   DECL_CONTEXT (field) = context;
11007   DECL_ALIGN (field) = 0;
11008   DECL_USER_ALIGN (field) = 0;
11009   if (prevfield != NULL_TREE)
11010     TREE_CHAIN (prevfield) = field;
11011
11012   return field;
11013 }
11014
11015 #endif
11016
11017 void
11018 ffecom_close_include (FILE *f)
11019 {
11020 #if FFECOM_GCC_INCLUDE
11021   ffecom_close_include_ (f);
11022 #endif
11023 }
11024
11025 int
11026 ffecom_decode_include_option (char *spec)
11027 {
11028 #if FFECOM_GCC_INCLUDE
11029   return ffecom_decode_include_option_ (spec);
11030 #else
11031   return 1;
11032 #endif
11033 }
11034
11035 /* End a compound statement (block).  */
11036
11037 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11038 tree
11039 ffecom_end_compstmt (void)
11040 {
11041   return bison_rule_compstmt_ ();
11042 }
11043 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
11044
11045 /* ffecom_end_transition -- Perform end transition on all symbols
11046
11047    ffecom_end_transition();
11048
11049    Calls ffecom_sym_end_transition for each global and local symbol.  */
11050
11051 void
11052 ffecom_end_transition ()
11053 {
11054 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11055   ffebld item;
11056 #endif
11057
11058   if (ffe_is_ffedebug ())
11059     fprintf (dmpout, "; end_stmt_transition\n");
11060
11061 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11062   ffecom_list_blockdata_ = NULL;
11063   ffecom_list_common_ = NULL;
11064 #endif
11065
11066   ffesymbol_drive (ffecom_sym_end_transition);
11067   if (ffe_is_ffedebug ())
11068     {
11069       ffestorag_report ();
11070 #if FFECOM_targetCURRENT == FFECOM_targetFFE
11071       ffesymbol_report_all ();
11072 #endif
11073     }
11074
11075 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11076   ffecom_start_progunit_ ();
11077
11078   for (item = ffecom_list_blockdata_;
11079        item != NULL;
11080        item = ffebld_trail (item))
11081     {
11082       ffebld callee;
11083       ffesymbol s;
11084       tree dt;
11085       tree t;
11086       tree var;
11087       int yes;
11088       static int number = 0;
11089
11090       callee = ffebld_head (item);
11091       s = ffebld_symter (callee);
11092       t = ffesymbol_hook (s).decl_tree;
11093       if (t == NULL_TREE)
11094         {
11095           s = ffecom_sym_transform_ (s);
11096           t = ffesymbol_hook (s).decl_tree;
11097         }
11098
11099       yes = suspend_momentary ();
11100
11101       dt = build_pointer_type (TREE_TYPE (t));
11102
11103       var = build_decl (VAR_DECL,
11104                         ffecom_get_invented_identifier ("__g77_forceload_%d",
11105                                                         number++),
11106                         dt);
11107       DECL_EXTERNAL (var) = 0;
11108       TREE_STATIC (var) = 1;
11109       TREE_PUBLIC (var) = 0;
11110       DECL_INITIAL (var) = error_mark_node;
11111       TREE_USED (var) = 1;
11112
11113       var = start_decl (var, FALSE);
11114
11115       t = ffecom_1 (ADDR_EXPR, dt, t);
11116
11117       finish_decl (var, t, FALSE);
11118
11119       resume_momentary (yes);
11120     }
11121
11122   /* This handles any COMMON areas that weren't referenced but have, for
11123      example, important initial data.  */
11124
11125   for (item = ffecom_list_common_;
11126        item != NULL;
11127        item = ffebld_trail (item))
11128     ffecom_transform_common_ (ffebld_symter (ffebld_head (item)));
11129
11130   ffecom_list_common_ = NULL;
11131 #endif
11132 }
11133
11134 /* ffecom_exec_transition -- Perform exec transition on all symbols
11135
11136    ffecom_exec_transition();
11137
11138    Calls ffecom_sym_exec_transition for each global and local symbol.
11139    Make sure error updating not inhibited.  */
11140
11141 void
11142 ffecom_exec_transition ()
11143 {
11144   bool inhibited;
11145
11146   if (ffe_is_ffedebug ())
11147     fprintf (dmpout, "; exec_stmt_transition\n");
11148
11149   inhibited = ffebad_inhibit ();
11150   ffebad_set_inhibit (FALSE);
11151
11152   ffesymbol_drive (ffecom_sym_exec_transition); /* Don't retract! */
11153   ffeequiv_exec_transition ();  /* Handle all pending EQUIVALENCEs. */
11154   if (ffe_is_ffedebug ())
11155     {
11156       ffestorag_report ();
11157 #if FFECOM_targetCURRENT == FFECOM_targetFFE
11158       ffesymbol_report_all ();
11159 #endif
11160     }
11161
11162   if (inhibited)
11163     ffebad_set_inhibit (TRUE);
11164 }
11165
11166 /* Handle assignment statement.
11167
11168    Convert dest and source using ffecom_expr, then join them
11169    with an ASSIGN op and pass the whole thing to expand_expr_stmt.  */
11170
11171 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11172 void
11173 ffecom_expand_let_stmt (ffebld dest, ffebld source)
11174 {
11175   tree dest_tree;
11176   tree dest_length;
11177   tree source_tree;
11178   tree expr_tree;
11179
11180   if (ffeinfo_basictype (ffebld_info (dest)) != FFEINFO_basictypeCHARACTER)
11181     {
11182       bool dest_used;
11183       tree assign_temp;
11184
11185       /* This attempts to replicate the test below, but must not be
11186          true when the test below is false.  (Always err on the side
11187          of creating unused temporaries, to avoid ICEs.)  */
11188       if (ffebld_op (dest) != FFEBLD_opSYMTER
11189           || ((dest_tree = ffesymbol_hook (ffebld_symter (dest)).decl_tree)
11190               && (TREE_CODE (dest_tree) != VAR_DECL
11191                   || TREE_ADDRESSABLE (dest_tree))))
11192         {
11193           ffecom_prepare_expr_ (source, dest);
11194           dest_used = TRUE;
11195         }
11196       else
11197         {
11198           ffecom_prepare_expr_ (source, NULL);
11199           dest_used = FALSE;
11200         }
11201
11202       ffecom_prepare_expr_w (NULL_TREE, dest);
11203
11204       /* For COMPLEX assignment like C1=C2, if partial overlap is possible,
11205          create a temporary through which the assignment is to take place,
11206          since MODIFY_EXPR doesn't handle partial overlap properly.  */
11207       if (ffebld_basictype (dest) == FFEINFO_basictypeCOMPLEX
11208           && ffecom_possible_partial_overlap_ (dest, source))
11209         {
11210           assign_temp = ffecom_make_tempvar ("complex_let",
11211                                              ffecom_tree_type
11212                                              [ffebld_basictype (dest)]
11213                                              [ffebld_kindtype (dest)],
11214                                              FFETARGET_charactersizeNONE,
11215                                              -1);
11216         }
11217       else
11218         assign_temp = NULL_TREE;
11219
11220       ffecom_prepare_end ();
11221
11222       dest_tree = ffecom_expr_w (NULL_TREE, dest);
11223       if (dest_tree == error_mark_node)
11224         return;
11225
11226       if ((TREE_CODE (dest_tree) != VAR_DECL)
11227           || TREE_ADDRESSABLE (dest_tree))
11228         source_tree = ffecom_expr_ (source, dest_tree, dest, &dest_used,
11229                                     FALSE, FALSE);
11230       else
11231         {
11232           assert (! dest_used);
11233           dest_used = FALSE;
11234           source_tree = ffecom_expr (source);
11235         }
11236       if (source_tree == error_mark_node)
11237         return;
11238
11239       if (dest_used)
11240         expr_tree = source_tree;
11241       else if (assign_temp)
11242         {
11243 #ifdef MOVE_EXPR
11244           /* The back end understands a conceptual move (evaluate source;
11245              store into dest), so use that, in case it can determine
11246              that it is going to use, say, two registers as temporaries
11247              anyway.  So don't use the temp (and someday avoid generating
11248              it, once this code starts triggering regularly).  */
11249           expr_tree = ffecom_2s (MOVE_EXPR, void_type_node,
11250                                  dest_tree,
11251                                  source_tree);
11252 #else
11253           expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11254                                  assign_temp,
11255                                  source_tree);
11256           expand_expr_stmt (expr_tree);
11257           expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11258                                  dest_tree,
11259                                  assign_temp);
11260 #endif
11261         }
11262       else
11263         expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11264                                dest_tree,
11265                                source_tree);
11266
11267       expand_expr_stmt (expr_tree);
11268       return;
11269     }
11270
11271   ffecom_prepare_let_char_ (ffebld_size_known (dest), source);
11272   ffecom_prepare_expr_w (NULL_TREE, dest);
11273
11274   ffecom_prepare_end ();
11275
11276   ffecom_char_args_ (&dest_tree, &dest_length, dest);
11277   ffecom_let_char_ (dest_tree, dest_length, ffebld_size_known (dest),
11278                     source);
11279 }
11280
11281 #endif
11282 /* ffecom_expr -- Transform expr into gcc tree
11283
11284    tree t;
11285    ffebld expr;  // FFE expression.
11286    tree = ffecom_expr(expr);
11287
11288    Recursive descent on expr while making corresponding tree nodes and
11289    attaching type info and such.  */
11290
11291 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11292 tree
11293 ffecom_expr (ffebld expr)
11294 {
11295   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, FALSE, FALSE);
11296 }
11297
11298 #endif
11299 /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT.  */
11300
11301 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11302 tree
11303 ffecom_expr_assign (ffebld expr)
11304 {
11305   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
11306 }
11307
11308 #endif
11309 /* Like ffecom_expr_rw, but return tree usable for ASSIGN.  */
11310
11311 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11312 tree
11313 ffecom_expr_assign_w (ffebld expr)
11314 {
11315   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
11316 }
11317
11318 #endif
11319 /* Transform expr for use as into read/write tree and stabilize the
11320    reference.  Not for use on CHARACTER expressions.
11321
11322    Recursive descent on expr while making corresponding tree nodes and
11323    attaching type info and such.  */
11324
11325 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11326 tree
11327 ffecom_expr_rw (tree type, ffebld expr)
11328 {
11329   assert (expr != NULL);
11330   /* Different target types not yet supported.  */
11331   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
11332
11333   return stabilize_reference (ffecom_expr (expr));
11334 }
11335
11336 #endif
11337 /* Transform expr for use as into write tree and stabilize the
11338    reference.  Not for use on CHARACTER expressions.
11339
11340    Recursive descent on expr while making corresponding tree nodes and
11341    attaching type info and such.  */
11342
11343 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11344 tree
11345 ffecom_expr_w (tree type, ffebld expr)
11346 {
11347   assert (expr != NULL);
11348   /* Different target types not yet supported.  */
11349   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
11350
11351   return stabilize_reference (ffecom_expr (expr));
11352 }
11353
11354 #endif
11355 /* Do global stuff.  */
11356
11357 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11358 void
11359 ffecom_finish_compile ()
11360 {
11361   assert (ffecom_outer_function_decl_ == NULL_TREE);
11362   assert (current_function_decl == NULL_TREE);
11363
11364   ffeglobal_drive (ffecom_finish_global_);
11365 }
11366
11367 #endif
11368 /* Public entry point for front end to access finish_decl.  */
11369
11370 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11371 void
11372 ffecom_finish_decl (tree decl, tree init, bool is_top_level)
11373 {
11374   assert (!is_top_level);
11375   finish_decl (decl, init, FALSE);
11376 }
11377
11378 #endif
11379 /* Finish a program unit.  */
11380
11381 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11382 void
11383 ffecom_finish_progunit ()
11384 {
11385   ffecom_end_compstmt ();
11386
11387   ffecom_previous_function_decl_ = current_function_decl;
11388   ffecom_which_entrypoint_decl_ = NULL_TREE;
11389
11390   finish_function (0);
11391 }
11392
11393 #endif
11394
11395 /* Wrapper for get_identifier.  pattern is sprintf-like.  */
11396
11397 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11398 tree
11399 ffecom_get_invented_identifier (const char *pattern, ...)
11400 {
11401   tree decl;
11402   char *nam;
11403   va_list ap;
11404
11405   va_start (ap, pattern);
11406   if (vasprintf (&nam, pattern, ap) == 0)
11407     abort ();
11408   va_end (ap);
11409   decl = get_identifier (nam);
11410   free (nam);
11411   IDENTIFIER_INVENTED (decl) = 1;
11412   return decl;
11413 }
11414
11415 ffeinfoBasictype
11416 ffecom_gfrt_basictype (ffecomGfrt gfrt)
11417 {
11418   assert (gfrt < FFECOM_gfrt);
11419
11420   switch (ffecom_gfrt_type_[gfrt])
11421     {
11422     case FFECOM_rttypeVOID_:
11423     case FFECOM_rttypeVOIDSTAR_:
11424       return FFEINFO_basictypeNONE;
11425
11426     case FFECOM_rttypeFTNINT_:
11427       return FFEINFO_basictypeINTEGER;
11428
11429     case FFECOM_rttypeINTEGER_:
11430       return FFEINFO_basictypeINTEGER;
11431
11432     case FFECOM_rttypeLONGINT_:
11433       return FFEINFO_basictypeINTEGER;
11434
11435     case FFECOM_rttypeLOGICAL_:
11436       return FFEINFO_basictypeLOGICAL;
11437
11438     case FFECOM_rttypeREAL_F2C_:
11439     case FFECOM_rttypeREAL_GNU_:
11440       return FFEINFO_basictypeREAL;
11441
11442     case FFECOM_rttypeCOMPLEX_F2C_:
11443     case FFECOM_rttypeCOMPLEX_GNU_:
11444       return FFEINFO_basictypeCOMPLEX;
11445
11446     case FFECOM_rttypeDOUBLE_:
11447     case FFECOM_rttypeDOUBLEREAL_:
11448       return FFEINFO_basictypeREAL;
11449
11450     case FFECOM_rttypeDBLCMPLX_F2C_:
11451     case FFECOM_rttypeDBLCMPLX_GNU_:
11452       return FFEINFO_basictypeCOMPLEX;
11453
11454     case FFECOM_rttypeCHARACTER_:
11455       return FFEINFO_basictypeCHARACTER;
11456
11457     default:
11458       return FFEINFO_basictypeANY;
11459     }
11460 }
11461
11462 ffeinfoKindtype
11463 ffecom_gfrt_kindtype (ffecomGfrt gfrt)
11464 {
11465   assert (gfrt < FFECOM_gfrt);
11466
11467   switch (ffecom_gfrt_type_[gfrt])
11468     {
11469     case FFECOM_rttypeVOID_:
11470     case FFECOM_rttypeVOIDSTAR_:
11471       return FFEINFO_kindtypeNONE;
11472
11473     case FFECOM_rttypeFTNINT_:
11474       return FFEINFO_kindtypeINTEGER1;
11475
11476     case FFECOM_rttypeINTEGER_:
11477       return FFEINFO_kindtypeINTEGER1;
11478
11479     case FFECOM_rttypeLONGINT_:
11480       return FFEINFO_kindtypeINTEGER4;
11481
11482     case FFECOM_rttypeLOGICAL_:
11483       return FFEINFO_kindtypeLOGICAL1;
11484
11485     case FFECOM_rttypeREAL_F2C_:
11486     case FFECOM_rttypeREAL_GNU_:
11487       return FFEINFO_kindtypeREAL1;
11488
11489     case FFECOM_rttypeCOMPLEX_F2C_:
11490     case FFECOM_rttypeCOMPLEX_GNU_:
11491       return FFEINFO_kindtypeREAL1;
11492
11493     case FFECOM_rttypeDOUBLE_:
11494     case FFECOM_rttypeDOUBLEREAL_:
11495       return FFEINFO_kindtypeREAL2;
11496
11497     case FFECOM_rttypeDBLCMPLX_F2C_:
11498     case FFECOM_rttypeDBLCMPLX_GNU_:
11499       return FFEINFO_kindtypeREAL2;
11500
11501     case FFECOM_rttypeCHARACTER_:
11502       return FFEINFO_kindtypeCHARACTER1;
11503
11504     default:
11505       return FFEINFO_kindtypeANY;
11506     }
11507 }
11508
11509 void
11510 ffecom_init_0 ()
11511 {
11512   tree endlink;
11513   int i;
11514   int j;
11515   tree t;
11516   tree field;
11517   ffetype type;
11518   ffetype base_type;
11519   tree double_ftype_double;
11520   tree float_ftype_float;
11521   tree ldouble_ftype_ldouble;
11522   tree ffecom_tree_ptr_to_fun_type_void;
11523
11524   /* This block of code comes from the now-obsolete cktyps.c.  It checks
11525      whether the compiler environment is buggy in known ways, some of which
11526      would, if not explicitly checked here, result in subtle bugs in g77.  */
11527
11528   if (ffe_is_do_internal_checks ())
11529     {
11530       static char names[][12]
11531         =
11532       {"bar", "bletch", "foo", "foobar"};
11533       char *name;
11534       unsigned long ul;
11535       double fl;
11536
11537       name = bsearch ("foo", &names[0], ARRAY_SIZE (names), sizeof (names[0]),
11538                       (int (*)(const void *, const void *)) strcmp);
11539       if (name != (char *) &names[2])
11540         {
11541           assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
11542                   == NULL);
11543           abort ();
11544         }
11545
11546       ul = strtoul ("123456789", NULL, 10);
11547       if (ul != 123456789L)
11548         {
11549           assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\
11550  in proj.h" == NULL);
11551           abort ();
11552         }
11553
11554       fl = atof ("56.789");
11555       if ((fl < 56.788) || (fl > 56.79))
11556         {
11557           assert ("atof not type double, fix your #include <stdio.h>"
11558                   == NULL);
11559           abort ();
11560         }
11561     }
11562
11563 #if FFECOM_GCC_INCLUDE
11564   ffecom_initialize_char_syntax_ ();
11565 #endif
11566
11567   ffecom_outer_function_decl_ = NULL_TREE;
11568   current_function_decl = NULL_TREE;
11569   named_labels = NULL_TREE;
11570   current_binding_level = NULL_BINDING_LEVEL;
11571   free_binding_level = NULL_BINDING_LEVEL;
11572   /* Make the binding_level structure for global names.  */
11573   pushlevel (0);
11574   global_binding_level = current_binding_level;
11575   current_binding_level->prep_state = 2;
11576
11577   build_common_tree_nodes (1);
11578
11579   /* Define `int' and `char' first so that dbx will output them first.  */
11580   pushdecl (build_decl (TYPE_DECL, get_identifier ("int"),
11581                         integer_type_node));
11582   pushdecl (build_decl (TYPE_DECL, get_identifier ("char"),
11583                         char_type_node));
11584   pushdecl (build_decl (TYPE_DECL, get_identifier ("long int"),
11585                         long_integer_type_node));
11586   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"),
11587                         unsigned_type_node));
11588   pushdecl (build_decl (TYPE_DECL, get_identifier ("long unsigned int"),
11589                         long_unsigned_type_node));
11590   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long int"),
11591                         long_long_integer_type_node));
11592   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long unsigned int"),
11593                         long_long_unsigned_type_node));
11594   pushdecl (build_decl (TYPE_DECL, get_identifier ("short int"),
11595                         short_integer_type_node));
11596   pushdecl (build_decl (TYPE_DECL, get_identifier ("short unsigned int"),
11597                         short_unsigned_type_node));
11598
11599   /* Set the sizetype before we make other types.  This *should* be the
11600      first type we create.  */
11601
11602   set_sizetype
11603     (TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE))));
11604   ffecom_typesize_pointer_
11605     = TREE_INT_CST_LOW (TYPE_SIZE (sizetype)) / BITS_PER_UNIT;
11606
11607   build_common_tree_nodes_2 (0);
11608
11609   /* Define both `signed char' and `unsigned char'.  */
11610   pushdecl (build_decl (TYPE_DECL, get_identifier ("signed char"),
11611                         signed_char_type_node));
11612
11613   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"),
11614                         unsigned_char_type_node));
11615
11616   pushdecl (build_decl (TYPE_DECL, get_identifier ("float"),
11617                         float_type_node));
11618   pushdecl (build_decl (TYPE_DECL, get_identifier ("double"),
11619                         double_type_node));
11620   pushdecl (build_decl (TYPE_DECL, get_identifier ("long double"),
11621                         long_double_type_node));
11622
11623   /* For now, override what build_common_tree_nodes has done.  */
11624   complex_integer_type_node = ffecom_make_complex_type_ (integer_type_node);
11625   complex_float_type_node = ffecom_make_complex_type_ (float_type_node);
11626   complex_double_type_node = ffecom_make_complex_type_ (double_type_node);
11627   complex_long_double_type_node
11628     = ffecom_make_complex_type_ (long_double_type_node);
11629
11630   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex int"),
11631                         complex_integer_type_node));
11632   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex float"),
11633                         complex_float_type_node));
11634   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex double"),
11635                         complex_double_type_node));
11636   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex long double"),
11637                         complex_long_double_type_node));
11638
11639   pushdecl (build_decl (TYPE_DECL, get_identifier ("void"),
11640                         void_type_node));
11641   /* We are not going to have real types in C with less than byte alignment,
11642      so we might as well not have any types that claim to have it.  */
11643   TYPE_ALIGN (void_type_node) = BITS_PER_UNIT;
11644   TYPE_USER_ALIGN (void_type_node) = 0;
11645
11646   string_type_node = build_pointer_type (char_type_node);
11647
11648   ffecom_tree_fun_type_void
11649     = build_function_type (void_type_node, NULL_TREE);
11650
11651   ffecom_tree_ptr_to_fun_type_void
11652     = build_pointer_type (ffecom_tree_fun_type_void);
11653
11654   endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
11655
11656   float_ftype_float
11657     = build_function_type (float_type_node,
11658                            tree_cons (NULL_TREE, float_type_node, endlink));
11659
11660   double_ftype_double
11661     = build_function_type (double_type_node,
11662                            tree_cons (NULL_TREE, double_type_node, endlink));
11663
11664   ldouble_ftype_ldouble
11665     = build_function_type (long_double_type_node,
11666                            tree_cons (NULL_TREE, long_double_type_node,
11667                                       endlink));
11668
11669   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11670     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11671       {
11672         ffecom_tree_type[i][j] = NULL_TREE;
11673         ffecom_tree_fun_type[i][j] = NULL_TREE;
11674         ffecom_tree_ptr_to_fun_type[i][j] = NULL_TREE;
11675         ffecom_f2c_typecode_[i][j] = -1;
11676       }
11677
11678   /* Set up standard g77 types.  Note that INTEGER and LOGICAL are set
11679      to size FLOAT_TYPE_SIZE because they have to be the same size as
11680      REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
11681      Compiler options and other such stuff that change the ways these
11682      types are set should not affect this particular setup.  */
11683
11684   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1]
11685     = t = make_signed_type (FLOAT_TYPE_SIZE);
11686   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer"),
11687                         t));
11688   type = ffetype_new ();
11689   base_type = type;
11690   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER1,
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_typesize_integer1_ = ffetype_size (type);
11700   assert (ffetype_size (type) == sizeof (ffetargetInteger1));
11701
11702   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER1]
11703     = t = make_unsigned_type (FLOAT_TYPE_SIZE); /* HOLLERITH means unsigned. */
11704   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned"),
11705                         t));
11706
11707   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER2]
11708     = t = make_signed_type (CHAR_TYPE_SIZE);
11709   pushdecl (build_decl (TYPE_DECL, get_identifier ("byte"),
11710                         t));
11711   type = ffetype_new ();
11712   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER2,
11713                     type);
11714   ffetype_set_ams (type,
11715                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11716                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11717   ffetype_set_star (base_type,
11718                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11719                     type);
11720   ffetype_set_kind (base_type, 3, type);
11721   assert (ffetype_size (type) == sizeof (ffetargetInteger2));
11722
11723   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER2]
11724     = t = make_unsigned_type (CHAR_TYPE_SIZE);
11725   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned byte"),
11726                         t));
11727
11728   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER3]
11729     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11730   pushdecl (build_decl (TYPE_DECL, get_identifier ("word"),
11731                         t));
11732   type = ffetype_new ();
11733   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER3,
11734                     type);
11735   ffetype_set_ams (type,
11736                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11737                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11738   ffetype_set_star (base_type,
11739                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11740                     type);
11741   ffetype_set_kind (base_type, 6, type);
11742   assert (ffetype_size (type) == sizeof (ffetargetInteger3));
11743
11744   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER3]
11745     = t = make_unsigned_type (CHAR_TYPE_SIZE * 2);
11746   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned word"),
11747                         t));
11748
11749   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER4]
11750     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11751   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer4"),
11752                         t));
11753   type = ffetype_new ();
11754   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER4,
11755                     type);
11756   ffetype_set_ams (type,
11757                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11758                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11759   ffetype_set_star (base_type,
11760                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11761                     type);
11762   ffetype_set_kind (base_type, 2, type);
11763   assert (ffetype_size (type) == sizeof (ffetargetInteger4));
11764
11765   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER4]
11766     = t = make_unsigned_type (FLOAT_TYPE_SIZE * 2);
11767   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned4"),
11768                         t));
11769
11770 #if 0
11771   if (ffe_is_do_internal_checks ()
11772       && LONG_TYPE_SIZE != FLOAT_TYPE_SIZE
11773       && LONG_TYPE_SIZE != CHAR_TYPE_SIZE
11774       && LONG_TYPE_SIZE != SHORT_TYPE_SIZE
11775       && LONG_TYPE_SIZE != LONG_LONG_TYPE_SIZE)
11776     {
11777       fprintf (stderr, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n",
11778                LONG_TYPE_SIZE);
11779     }
11780 #endif
11781
11782   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL1]
11783     = t = make_signed_type (FLOAT_TYPE_SIZE);
11784   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical"),
11785                         t));
11786   type = ffetype_new ();
11787   base_type = type;
11788   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL1,
11789                     type);
11790   ffetype_set_ams (type,
11791                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11792                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11793   ffetype_set_star (base_type,
11794                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11795                     type);
11796   ffetype_set_kind (base_type, 1, type);
11797   assert (ffetype_size (type) == sizeof (ffetargetLogical1));
11798
11799   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL2]
11800     = t = make_signed_type (CHAR_TYPE_SIZE);
11801   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical2"),
11802                         t));
11803   type = ffetype_new ();
11804   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL2,
11805                     type);
11806   ffetype_set_ams (type,
11807                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11808                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11809   ffetype_set_star (base_type,
11810                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11811                     type);
11812   ffetype_set_kind (base_type, 3, type);
11813   assert (ffetype_size (type) == sizeof (ffetargetLogical2));
11814
11815   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL3]
11816     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11817   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical3"),
11818                         t));
11819   type = ffetype_new ();
11820   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL3,
11821                     type);
11822   ffetype_set_ams (type,
11823                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11824                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11825   ffetype_set_star (base_type,
11826                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11827                     type);
11828   ffetype_set_kind (base_type, 6, type);
11829   assert (ffetype_size (type) == sizeof (ffetargetLogical3));
11830
11831   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL4]
11832     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11833   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical4"),
11834                         t));
11835   type = ffetype_new ();
11836   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL4,
11837                     type);
11838   ffetype_set_ams (type,
11839                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11840                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11841   ffetype_set_star (base_type,
11842                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11843                     type);
11844   ffetype_set_kind (base_type, 2, type);
11845   assert (ffetype_size (type) == sizeof (ffetargetLogical4));
11846
11847   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11848     = t = make_node (REAL_TYPE);
11849   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE;
11850   pushdecl (build_decl (TYPE_DECL, get_identifier ("real"),
11851                         t));
11852   layout_type (t);
11853   type = ffetype_new ();
11854   base_type = type;
11855   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL1,
11856                     type);
11857   ffetype_set_ams (type,
11858                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11859                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11860   ffetype_set_star (base_type,
11861                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11862                     type);
11863   ffetype_set_kind (base_type, 1, type);
11864   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11865     = FFETARGET_f2cTYREAL;
11866   assert (ffetype_size (type) == sizeof (ffetargetReal1));
11867
11868   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREALDOUBLE]
11869     = t = make_node (REAL_TYPE);
11870   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE * 2;     /* Always twice REAL. */
11871   pushdecl (build_decl (TYPE_DECL, get_identifier ("double precision"),
11872                         t));
11873   layout_type (t);
11874   type = ffetype_new ();
11875   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
11876                     type);
11877   ffetype_set_ams (type,
11878                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11879                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11880   ffetype_set_star (base_type,
11881                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11882                     type);
11883   ffetype_set_kind (base_type, 2, type);
11884   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]
11885     = FFETARGET_f2cTYDREAL;
11886   assert (ffetype_size (type) == sizeof (ffetargetReal2));
11887
11888   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11889     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]);
11890   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex"),
11891                         t));
11892   type = ffetype_new ();
11893   base_type = type;
11894   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL1,
11895                     type);
11896   ffetype_set_ams (type,
11897                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11898                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11899   ffetype_set_star (base_type,
11900                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11901                     type);
11902   ffetype_set_kind (base_type, 1, type);
11903   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11904     = FFETARGET_f2cTYCOMPLEX;
11905   assert (ffetype_size (type) == sizeof (ffetargetComplex1));
11906
11907   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREALDOUBLE]
11908     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]);
11909   pushdecl (build_decl (TYPE_DECL, get_identifier ("double complex"),
11910                         t));
11911   type = ffetype_new ();
11912   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREALDOUBLE,
11913                     type);
11914   ffetype_set_ams (type,
11915                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11916                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11917   ffetype_set_star (base_type,
11918                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11919                     type);
11920   ffetype_set_kind (base_type, 2,
11921                     type);
11922   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL2]
11923     = FFETARGET_f2cTYDCOMPLEX;
11924   assert (ffetype_size (type) == sizeof (ffetargetComplex2));
11925
11926   /* Make function and ptr-to-function types for non-CHARACTER types. */
11927
11928   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11929     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11930       {
11931         if ((t = ffecom_tree_type[i][j]) != NULL_TREE)
11932           {
11933             if (i == FFEINFO_basictypeINTEGER)
11934               {
11935                 /* Figure out the smallest INTEGER type that can hold
11936                    a pointer on this machine. */
11937                 if (GET_MODE_SIZE (TYPE_MODE (t))
11938                     >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
11939                   {
11940                     if ((ffecom_pointer_kind_ == FFEINFO_kindtypeNONE)
11941                         || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type[i][ffecom_pointer_kind_]))
11942                             > GET_MODE_SIZE (TYPE_MODE (t))))
11943                       ffecom_pointer_kind_ = j;
11944                   }
11945               }
11946             else if (i == FFEINFO_basictypeCOMPLEX)
11947               t = void_type_node;
11948             /* For f2c compatibility, REAL functions are really
11949                implemented as DOUBLE PRECISION.  */
11950             else if ((i == FFEINFO_basictypeREAL)
11951                      && (j == FFEINFO_kindtypeREAL1))
11952               t = ffecom_tree_type
11953                 [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2];
11954
11955             t = ffecom_tree_fun_type[i][j] = build_function_type (t,
11956                                                                   NULL_TREE);
11957             ffecom_tree_ptr_to_fun_type[i][j] = build_pointer_type (t);
11958           }
11959       }
11960
11961   /* Set up pointer types.  */
11962
11963   if (ffecom_pointer_kind_ == FFEINFO_basictypeNONE)
11964     fatal ("no INTEGER type can hold a pointer on this configuration");
11965   else if (0 && ffe_is_do_internal_checks ())
11966     fprintf (stderr, "Pointer type kt=%d\n", ffecom_pointer_kind_);
11967   ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER,
11968                                   FFEINFO_kindtypeINTEGERDEFAULT),
11969                     7,
11970                     ffeinfo_type (FFEINFO_basictypeINTEGER,
11971                                   ffecom_pointer_kind_));
11972
11973   if (ffe_is_ugly_assign ())
11974     ffecom_label_kind_ = ffecom_pointer_kind_;  /* Require ASSIGN etc to this. */
11975   else
11976     ffecom_label_kind_ = FFEINFO_kindtypeINTEGERDEFAULT;
11977   if (0 && ffe_is_do_internal_checks ())
11978     fprintf (stderr, "Label type kt=%d\n", ffecom_label_kind_);
11979
11980   ffecom_integer_type_node
11981     = ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1];
11982   ffecom_integer_zero_node = convert (ffecom_integer_type_node,
11983                                       integer_zero_node);
11984   ffecom_integer_one_node = convert (ffecom_integer_type_node,
11985                                      integer_one_node);
11986
11987   /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
11988      Turns out that by TYLONG, runtime/libI77/lio.h really means
11989      "whatever size an ftnint is".  For consistency and sanity,
11990      com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
11991      all are INTEGER, which we also make out of whatever back-end
11992      integer type is FLOAT_TYPE_SIZE bits wide.  This change, from
11993      LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
11994      accommodate machines like the Alpha.  Note that this suggests
11995      f2c and libf2c are missing a distinction perhaps needed on
11996      some machines between "int" and "long int".  -- burley 0.5.5 950215 */
11997
11998   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, FLOAT_TYPE_SIZE,
11999                             FFETARGET_f2cTYLONG);
12000   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, SHORT_TYPE_SIZE,
12001                             FFETARGET_f2cTYSHORT);
12002   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, CHAR_TYPE_SIZE,
12003                             FFETARGET_f2cTYINT1);
12004   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, LONG_LONG_TYPE_SIZE,
12005                             FFETARGET_f2cTYQUAD);
12006   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, FLOAT_TYPE_SIZE,
12007                             FFETARGET_f2cTYLOGICAL);
12008   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, SHORT_TYPE_SIZE,
12009                             FFETARGET_f2cTYLOGICAL2);
12010   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, CHAR_TYPE_SIZE,
12011                             FFETARGET_f2cTYLOGICAL1);
12012   /* ~~~Not really such a type in libf2c, e.g. I/O support?  */
12013   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, LONG_LONG_TYPE_SIZE,
12014                             FFETARGET_f2cTYQUAD);
12015
12016   /* CHARACTER stuff is all special-cased, so it is not handled in the above
12017      loop.  CHARACTER items are built as arrays of unsigned char.  */
12018
12019   ffecom_tree_type[FFEINFO_basictypeCHARACTER]
12020     [FFEINFO_kindtypeCHARACTER1] = t = char_type_node;
12021   type = ffetype_new ();
12022   base_type = type;
12023   ffeinfo_set_type (FFEINFO_basictypeCHARACTER,
12024                     FFEINFO_kindtypeCHARACTER1,
12025                     type);
12026   ffetype_set_ams (type,
12027                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
12028                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
12029   ffetype_set_kind (base_type, 1, type);
12030   assert (ffetype_size (type)
12031           == sizeof (((ffetargetCharacter1) { 0, NULL }).text[0]));
12032
12033   ffecom_tree_fun_type[FFEINFO_basictypeCHARACTER]
12034     [FFEINFO_kindtypeCHARACTER1] = ffecom_tree_fun_type_void;
12035   ffecom_tree_ptr_to_fun_type[FFEINFO_basictypeCHARACTER]
12036     [FFEINFO_kindtypeCHARACTER1]
12037     = ffecom_tree_ptr_to_fun_type_void;
12038   ffecom_f2c_typecode_[FFEINFO_basictypeCHARACTER][FFEINFO_kindtypeCHARACTER1]
12039     = FFETARGET_f2cTYCHAR;
12040
12041   ffecom_f2c_typecode_[FFEINFO_basictypeANY][FFEINFO_kindtypeANY]
12042     = 0;
12043
12044   /* Make multi-return-value type and fields. */
12045
12046   ffecom_multi_type_node_ = make_node (UNION_TYPE);
12047
12048   field = NULL_TREE;
12049
12050   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
12051     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
12052       {
12053         char name[30];
12054
12055         if (ffecom_tree_type[i][j] == NULL_TREE)
12056           continue;             /* Not supported. */
12057         sprintf (&name[0], "bt_%s_kt_%s",
12058                  ffeinfo_basictype_string ((ffeinfoBasictype) i),
12059                  ffeinfo_kindtype_string ((ffeinfoKindtype) j));
12060         ffecom_multi_fields_[i][j] = build_decl (FIELD_DECL,
12061                                                  get_identifier (name),
12062                                                  ffecom_tree_type[i][j]);
12063         DECL_CONTEXT (ffecom_multi_fields_[i][j])
12064           = ffecom_multi_type_node_;
12065         DECL_ALIGN (ffecom_multi_fields_[i][j]) = 0;
12066         DECL_USER_ALIGN (ffecom_multi_fields_[i][j]) = 0;
12067         TREE_CHAIN (ffecom_multi_fields_[i][j]) = field;
12068         field = ffecom_multi_fields_[i][j];
12069       }
12070
12071   TYPE_FIELDS (ffecom_multi_type_node_) = field;
12072   layout_type (ffecom_multi_type_node_);
12073
12074   /* Subroutines usually return integer because they might have alternate
12075      returns. */
12076
12077   ffecom_tree_subr_type
12078     = build_function_type (integer_type_node, NULL_TREE);
12079   ffecom_tree_ptr_to_subr_type
12080     = build_pointer_type (ffecom_tree_subr_type);
12081   ffecom_tree_blockdata_type
12082     = build_function_type (void_type_node, NULL_TREE);
12083
12084   builtin_function ("__builtin_sqrtf", float_ftype_float,
12085                     BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrtf");
12086   builtin_function ("__builtin_fsqrt", double_ftype_double,
12087                     BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrt");
12088   builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble,
12089                     BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrtl");
12090   builtin_function ("__builtin_sinf", float_ftype_float,
12091                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sinf");
12092   builtin_function ("__builtin_sin", double_ftype_double,
12093                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sin");
12094   builtin_function ("__builtin_sinl", ldouble_ftype_ldouble,
12095                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sinl");
12096   builtin_function ("__builtin_cosf", float_ftype_float,
12097                     BUILT_IN_COS, BUILT_IN_NORMAL, "cosf");
12098   builtin_function ("__builtin_cos", double_ftype_double,
12099                     BUILT_IN_COS, BUILT_IN_NORMAL, "cos");
12100   builtin_function ("__builtin_cosl", ldouble_ftype_ldouble,
12101                     BUILT_IN_COS, BUILT_IN_NORMAL, "cosl");
12102
12103 #if BUILT_FOR_270
12104   pedantic_lvalues = FALSE;
12105 #endif
12106
12107   ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node,
12108                          FFECOM_f2cINTEGER,
12109                          "integer");
12110   ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node,
12111                          FFECOM_f2cADDRESS,
12112                          "address");
12113   ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node,
12114                          FFECOM_f2cREAL,
12115                          "real");
12116   ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node,
12117                          FFECOM_f2cDOUBLEREAL,
12118                          "doublereal");
12119   ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node,
12120                          FFECOM_f2cCOMPLEX,
12121                          "complex");
12122   ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node,
12123                          FFECOM_f2cDOUBLECOMPLEX,
12124                          "doublecomplex");
12125   ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node,
12126                          FFECOM_f2cLONGINT,
12127                          "longint");
12128   ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node,
12129                          FFECOM_f2cLOGICAL,
12130                          "logical");
12131   ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node,
12132                          FFECOM_f2cFLAG,
12133                          "flag");
12134   ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node,
12135                          FFECOM_f2cFTNLEN,
12136                          "ftnlen");
12137   ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node,
12138                          FFECOM_f2cFTNINT,
12139                          "ftnint");
12140
12141   ffecom_f2c_ftnlen_zero_node
12142     = convert (ffecom_f2c_ftnlen_type_node, integer_zero_node);
12143
12144   ffecom_f2c_ftnlen_one_node
12145     = convert (ffecom_f2c_ftnlen_type_node, integer_one_node);
12146
12147   ffecom_f2c_ftnlen_two_node = build_int_2 (2, 0);
12148   TREE_TYPE (ffecom_f2c_ftnlen_two_node) = ffecom_integer_type_node;
12149
12150   ffecom_f2c_ptr_to_ftnlen_type_node
12151     = build_pointer_type (ffecom_f2c_ftnlen_type_node);
12152
12153   ffecom_f2c_ptr_to_ftnint_type_node
12154     = build_pointer_type (ffecom_f2c_ftnint_type_node);
12155
12156   ffecom_f2c_ptr_to_integer_type_node
12157     = build_pointer_type (ffecom_f2c_integer_type_node);
12158
12159   ffecom_f2c_ptr_to_real_type_node
12160     = build_pointer_type (ffecom_f2c_real_type_node);
12161
12162   ffecom_float_zero_ = build_real (float_type_node, dconst0);
12163   ffecom_double_zero_ = build_real (double_type_node, dconst0);
12164   {
12165     REAL_VALUE_TYPE point_5;
12166
12167 #ifdef REAL_ARITHMETIC
12168     REAL_ARITHMETIC (point_5, RDIV_EXPR, dconst1, dconst2);
12169 #else
12170     point_5 = .5;
12171 #endif
12172     ffecom_float_half_ = build_real (float_type_node, point_5);
12173     ffecom_double_half_ = build_real (double_type_node, point_5);
12174   }
12175
12176   /* Do "extern int xargc;".  */
12177
12178   ffecom_tree_xargc_ = build_decl (VAR_DECL,
12179                                    get_identifier ("f__xargc"),
12180                                    integer_type_node);
12181   DECL_EXTERNAL (ffecom_tree_xargc_) = 1;
12182   TREE_STATIC (ffecom_tree_xargc_) = 1;
12183   TREE_PUBLIC (ffecom_tree_xargc_) = 1;
12184   ffecom_tree_xargc_ = start_decl (ffecom_tree_xargc_, FALSE);
12185   finish_decl (ffecom_tree_xargc_, NULL_TREE, FALSE);
12186
12187 #if 0   /* This is being fixed, and seems to be working now. */
12188   if ((FLOAT_TYPE_SIZE != 32)
12189       || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))) != 32))
12190     {
12191       warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,",
12192                (int) FLOAT_TYPE_SIZE);
12193       warning ("and pointers are %d bits wide, but g77 doesn't yet work",
12194           (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))));
12195       warning ("properly unless they all are 32 bits wide.");
12196       warning ("Please keep this in mind before you report bugs.  g77 should");
12197       warning ("support non-32-bit machines better as of version 0.6.");
12198     }
12199 #endif
12200
12201 #if 0   /* Code in ste.c that would crash has been commented out. */
12202   if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
12203       < TYPE_PRECISION (string_type_node))
12204     /* I/O will probably crash.  */
12205     warning ("configuration: char * holds %d bits, but ftnlen only %d",
12206              TYPE_PRECISION (string_type_node),
12207              TYPE_PRECISION (ffecom_f2c_ftnlen_type_node));
12208 #endif
12209
12210 #if 0   /* ASSIGN-related stuff has been changed to accommodate this. */
12211   if (TYPE_PRECISION (ffecom_integer_type_node)
12212       < TYPE_PRECISION (string_type_node))
12213     /* ASSIGN 10 TO I will crash.  */
12214     warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
12215  ASSIGN statement might fail",
12216              TYPE_PRECISION (string_type_node),
12217              TYPE_PRECISION (ffecom_integer_type_node));
12218 #endif
12219 }
12220
12221 #endif
12222 /* ffecom_init_2 -- Initialize
12223
12224    ffecom_init_2();  */
12225
12226 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12227 void
12228 ffecom_init_2 ()
12229 {
12230   assert (ffecom_outer_function_decl_ == NULL_TREE);
12231   assert (current_function_decl == NULL_TREE);
12232   assert (ffecom_which_entrypoint_decl_ == NULL_TREE);
12233
12234   ffecom_master_arglist_ = NULL;
12235   ++ffecom_num_fns_;
12236   ffecom_primary_entry_ = NULL;
12237   ffecom_is_altreturning_ = FALSE;
12238   ffecom_func_result_ = NULL_TREE;
12239   ffecom_multi_retval_ = NULL_TREE;
12240 }
12241
12242 #endif
12243 /* ffecom_list_expr -- Transform list of exprs into gcc tree
12244
12245    tree t;
12246    ffebld expr;  // FFE opITEM list.
12247    tree = ffecom_list_expr(expr);
12248
12249    List of actual args is transformed into corresponding gcc backend list.  */
12250
12251 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12252 tree
12253 ffecom_list_expr (ffebld expr)
12254 {
12255   tree list;
12256   tree *plist = &list;
12257   tree trail = NULL_TREE;       /* Append char length args here. */
12258   tree *ptrail = &trail;
12259   tree length;
12260
12261   while (expr != NULL)
12262     {
12263       tree texpr = ffecom_arg_expr (ffebld_head (expr), &length);
12264
12265       if (texpr == error_mark_node)
12266         return error_mark_node;
12267
12268       *plist = build_tree_list (NULL_TREE, texpr);
12269       plist = &TREE_CHAIN (*plist);
12270       expr = ffebld_trail (expr);
12271       if (length != NULL_TREE)
12272         {
12273           *ptrail = build_tree_list (NULL_TREE, length);
12274           ptrail = &TREE_CHAIN (*ptrail);
12275         }
12276     }
12277
12278   *plist = trail;
12279
12280   return list;
12281 }
12282
12283 #endif
12284 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
12285
12286    tree t;
12287    ffebld expr;  // FFE opITEM list.
12288    tree = ffecom_list_ptr_to_expr(expr);
12289
12290    List of actual args is transformed into corresponding gcc backend list for
12291    use in calling an external procedure (vs. a statement function).  */
12292
12293 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12294 tree
12295 ffecom_list_ptr_to_expr (ffebld expr)
12296 {
12297   tree list;
12298   tree *plist = &list;
12299   tree trail = NULL_TREE;       /* Append char length args here. */
12300   tree *ptrail = &trail;
12301   tree length;
12302
12303   while (expr != NULL)
12304     {
12305       tree texpr = ffecom_arg_ptr_to_expr (ffebld_head (expr), &length);
12306
12307       if (texpr == error_mark_node)
12308         return error_mark_node;
12309
12310       *plist = build_tree_list (NULL_TREE, texpr);
12311       plist = &TREE_CHAIN (*plist);
12312       expr = ffebld_trail (expr);
12313       if (length != NULL_TREE)
12314         {
12315           *ptrail = build_tree_list (NULL_TREE, length);
12316           ptrail = &TREE_CHAIN (*ptrail);
12317         }
12318     }
12319
12320   *plist = trail;
12321
12322   return list;
12323 }
12324
12325 #endif
12326 /* Obtain gcc's LABEL_DECL tree for label.  */
12327
12328 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12329 tree
12330 ffecom_lookup_label (ffelab label)
12331 {
12332   tree glabel;
12333
12334   if (ffelab_hook (label) == NULL_TREE)
12335     {
12336       char labelname[16];
12337
12338       switch (ffelab_type (label))
12339         {
12340         case FFELAB_typeLOOPEND:
12341         case FFELAB_typeNOTLOOP:
12342         case FFELAB_typeENDIF:
12343           sprintf (labelname, "%" ffelabValue_f "u", ffelab_value (label));
12344           glabel = build_decl (LABEL_DECL, get_identifier (labelname),
12345                                void_type_node);
12346           DECL_CONTEXT (glabel) = current_function_decl;
12347           DECL_MODE (glabel) = VOIDmode;
12348           break;
12349
12350         case FFELAB_typeFORMAT:
12351           glabel = build_decl (VAR_DECL,
12352                                ffecom_get_invented_identifier
12353                                ("__g77_format_%d", (int) ffelab_value (label)),
12354                                build_type_variant (build_array_type
12355                                                    (char_type_node,
12356                                                     NULL_TREE),
12357                                                    1, 0));
12358           TREE_CONSTANT (glabel) = 1;
12359           TREE_STATIC (glabel) = 1;
12360           DECL_CONTEXT (glabel) = 0;
12361           DECL_INITIAL (glabel) = NULL;
12362           make_decl_rtl (glabel, NULL, 0);
12363           expand_decl (glabel);
12364
12365           ffecom_save_tree_forever (glabel);
12366
12367           break;
12368
12369         case FFELAB_typeANY:
12370           glabel = error_mark_node;
12371           break;
12372
12373         default:
12374           assert ("bad label type" == NULL);
12375           glabel = NULL;
12376           break;
12377         }
12378       ffelab_set_hook (label, glabel);
12379     }
12380   else
12381     {
12382       glabel = ffelab_hook (label);
12383     }
12384
12385   return glabel;
12386 }
12387
12388 #endif
12389 /* Stabilizes the arguments.  Don't use this if the lhs and rhs come from
12390    a single source specification (as in the fourth argument of MVBITS).
12391    If the type is NULL_TREE, the type of lhs is used to make the type of
12392    the MODIFY_EXPR.  */
12393
12394 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12395 tree
12396 ffecom_modify (tree newtype, tree lhs,
12397                tree rhs)
12398 {
12399   if (lhs == error_mark_node || rhs == error_mark_node)
12400     return error_mark_node;
12401
12402   if (newtype == NULL_TREE)
12403     newtype = TREE_TYPE (lhs);
12404
12405   if (TREE_SIDE_EFFECTS (lhs))
12406     lhs = stabilize_reference (lhs);
12407
12408   return ffecom_2s (MODIFY_EXPR, newtype, lhs, rhs);
12409 }
12410
12411 #endif
12412
12413 /* Register source file name.  */
12414
12415 void
12416 ffecom_file (const char *name)
12417 {
12418 #if FFECOM_GCC_INCLUDE
12419   ffecom_file_ (name);
12420 #endif
12421 }
12422
12423 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
12424
12425    ffestorag st;
12426    ffecom_notify_init_storage(st);
12427
12428    Gets called when all possible units in an aggregate storage area (a LOCAL
12429    with equivalences or a COMMON) have been initialized.  The initialization
12430    info either is in ffestorag_init or, if that is NULL,
12431    ffestorag_accretion:
12432
12433    ffestorag_init may contain an opCONTER or opARRTER.  opCONTER may occur
12434    even for an array if the array is one element in length!
12435
12436    ffestorag_accretion will contain an opACCTER.  It is much like an
12437    opARRTER except it has an ffebit object in it instead of just a size.
12438    The back end can use the info in the ffebit object, if it wants, to
12439    reduce the amount of actual initialization, but in any case it should
12440    kill the ffebit object when done.  Also, set accretion to NULL but
12441    init to a non-NULL value.
12442
12443    After performing initialization, DO NOT set init to NULL, because that'll
12444    tell the front end it is ok for more initialization to happen.  Instead,
12445    set init to an opANY expression or some such thing that you can use to
12446    tell that you've already initialized the object.
12447
12448    27-Oct-91  JCB  1.1
12449       Support two-pass FFE.  */
12450
12451 void
12452 ffecom_notify_init_storage (ffestorag st)
12453 {
12454   ffebld init;                  /* The initialization expression. */
12455 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12456   ffetargetOffset size;         /* The size of the entity. */
12457   ffetargetAlign pad;           /* Its initial padding. */
12458 #endif
12459
12460   if (ffestorag_init (st) == NULL)
12461     {
12462       init = ffestorag_accretion (st);
12463       assert (init != NULL);
12464       ffestorag_set_accretion (st, NULL);
12465       ffestorag_set_accretes (st, 0);
12466
12467 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12468       /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12469       size = ffebld_accter_size (init);
12470       pad = ffebld_accter_pad (init);
12471       ffebit_kill (ffebld_accter_bits (init));
12472       ffebld_set_op (init, FFEBLD_opARRTER);
12473       ffebld_set_arrter (init, ffebld_accter (init));
12474       ffebld_arrter_set_size (init, size);
12475       ffebld_arrter_set_pad (init, size);
12476 #endif
12477
12478 #if FFECOM_TWOPASS
12479       ffestorag_set_init (st, init);
12480 #endif
12481     }
12482 #if FFECOM_ONEPASS
12483   else
12484     init = ffestorag_init (st);
12485 #endif
12486
12487 #if FFECOM_ONEPASS              /* Process the inits, wipe 'em out. */
12488   ffestorag_set_init (st, ffebld_new_any ());
12489
12490   if (ffebld_op (init) == FFEBLD_opANY)
12491     return;                     /* Oh, we already did this! */
12492
12493 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12494   {
12495     ffesymbol s;
12496
12497     if (ffestorag_symbol (st) != NULL)
12498       s = ffestorag_symbol (st);
12499     else
12500       s = ffestorag_typesymbol (st);
12501
12502     fprintf (dmpout, "= initialize_storage \"%s\" ",
12503              (s != NULL) ? ffesymbol_text (s) : "(unnamed)");
12504     ffebld_dump (init);
12505     fputc ('\n', dmpout);
12506   }
12507 #endif
12508
12509 #endif /* if FFECOM_ONEPASS */
12510 }
12511
12512 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12513
12514    ffesymbol s;
12515    ffecom_notify_init_symbol(s);
12516
12517    Gets called when all possible units in a symbol (not placed in COMMON
12518    or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12519    have been initialized.  The initialization info either is in
12520    ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12521
12522    ffesymbol_init may contain an opCONTER or opARRTER.  opCONTER may occur
12523    even for an array if the array is one element in length!
12524
12525    ffesymbol_accretion will contain an opACCTER.  It is much like an
12526    opARRTER except it has an ffebit object in it instead of just a size.
12527    The back end can use the info in the ffebit object, if it wants, to
12528    reduce the amount of actual initialization, but in any case it should
12529    kill the ffebit object when done.  Also, set accretion to NULL but
12530    init to a non-NULL value.
12531
12532    After performing initialization, DO NOT set init to NULL, because that'll
12533    tell the front end it is ok for more initialization to happen.  Instead,
12534    set init to an opANY expression or some such thing that you can use to
12535    tell that you've already initialized the object.
12536
12537    27-Oct-91  JCB  1.1
12538       Support two-pass FFE.  */
12539
12540 void
12541 ffecom_notify_init_symbol (ffesymbol s)
12542 {
12543   ffebld init;                  /* The initialization expression. */
12544 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12545   ffetargetOffset size;         /* The size of the entity. */
12546   ffetargetAlign pad;           /* Its initial padding. */
12547 #endif
12548
12549   if (ffesymbol_storage (s) == NULL)
12550     return;                     /* Do nothing until COMMON/EQUIVALENCE
12551                                    possibilities checked. */
12552
12553   if ((ffesymbol_init (s) == NULL)
12554       && ((init = ffesymbol_accretion (s)) != NULL))
12555     {
12556       ffesymbol_set_accretion (s, NULL);
12557       ffesymbol_set_accretes (s, 0);
12558
12559 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12560       /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12561       size = ffebld_accter_size (init);
12562       pad = ffebld_accter_pad (init);
12563       ffebit_kill (ffebld_accter_bits (init));
12564       ffebld_set_op (init, FFEBLD_opARRTER);
12565       ffebld_set_arrter (init, ffebld_accter (init));
12566       ffebld_arrter_set_size (init, size);
12567       ffebld_arrter_set_pad (init, size);
12568 #endif
12569
12570 #if FFECOM_TWOPASS
12571       ffesymbol_set_init (s, init);
12572 #endif
12573     }
12574 #if FFECOM_ONEPASS
12575   else
12576     init = ffesymbol_init (s);
12577 #endif
12578
12579 #if FFECOM_ONEPASS
12580   ffesymbol_set_init (s, ffebld_new_any ());
12581
12582   if (ffebld_op (init) == FFEBLD_opANY)
12583     return;                     /* Oh, we already did this! */
12584
12585 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12586   fprintf (dmpout, "= initialize_symbol \"%s\" ", ffesymbol_text (s));
12587   ffebld_dump (init);
12588   fputc ('\n', dmpout);
12589 #endif
12590
12591 #endif /* if FFECOM_ONEPASS */
12592 }
12593
12594 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12595
12596    ffesymbol s;
12597    ffecom_notify_primary_entry(s);
12598
12599    Gets called when implicit or explicit PROGRAM statement seen or when
12600    FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12601    global symbol that serves as the entry point.  */
12602
12603 void
12604 ffecom_notify_primary_entry (ffesymbol s)
12605 {
12606   ffecom_primary_entry_ = s;
12607   ffecom_primary_entry_kind_ = ffesymbol_kind (s);
12608
12609   if ((ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
12610       || (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE))
12611     ffecom_primary_entry_is_proc_ = TRUE;
12612   else
12613     ffecom_primary_entry_is_proc_ = FALSE;
12614
12615   if (!ffe_is_silent ())
12616     {
12617       if (ffecom_primary_entry_kind_ == FFEINFO_kindPROGRAM)
12618         fprintf (stderr, "%s:\n", ffesymbol_text (s));
12619       else
12620         fprintf (stderr, "  %s:\n", ffesymbol_text (s));
12621     }
12622
12623 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12624   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
12625     {
12626       ffebld list;
12627       ffebld arg;
12628
12629       for (list = ffesymbol_dummyargs (s);
12630            list != NULL;
12631            list = ffebld_trail (list))
12632         {
12633           arg = ffebld_head (list);
12634           if (ffebld_op (arg) == FFEBLD_opSTAR)
12635             {
12636               ffecom_is_altreturning_ = TRUE;
12637               break;
12638             }
12639         }
12640     }
12641 #endif
12642 }
12643
12644 FILE *
12645 ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c)
12646 {
12647 #if FFECOM_GCC_INCLUDE
12648   return ffecom_open_include_ (name, l, c);
12649 #else
12650   return fopen (name, "r");
12651 #endif
12652 }
12653
12654 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
12655
12656    tree t;
12657    ffebld expr;  // FFE expression.
12658    tree = ffecom_ptr_to_expr(expr);
12659
12660    Like ffecom_expr, but sticks address-of in front of most things.  */
12661
12662 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12663 tree
12664 ffecom_ptr_to_expr (ffebld expr)
12665 {
12666   tree item;
12667   ffeinfoBasictype bt;
12668   ffeinfoKindtype kt;
12669   ffesymbol s;
12670
12671   assert (expr != NULL);
12672
12673   switch (ffebld_op (expr))
12674     {
12675     case FFEBLD_opSYMTER:
12676       s = ffebld_symter (expr);
12677       if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
12678         {
12679           ffecomGfrt ix;
12680
12681           ix = ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr));
12682           assert (ix != FFECOM_gfrt);
12683           if ((item = ffecom_gfrt_[ix]) == NULL_TREE)
12684             {
12685               ffecom_make_gfrt_ (ix);
12686               item = ffecom_gfrt_[ix];
12687             }
12688         }
12689       else
12690         {
12691           item = ffesymbol_hook (s).decl_tree;
12692           if (item == NULL_TREE)
12693             {
12694               s = ffecom_sym_transform_ (s);
12695               item = ffesymbol_hook (s).decl_tree;
12696             }
12697         }
12698       assert (item != NULL);
12699       if (item == error_mark_node)
12700         return item;
12701       if (!ffesymbol_hook (s).addr)
12702         item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12703                          item);
12704       return item;
12705
12706     case FFEBLD_opARRAYREF:
12707       return ffecom_arrayref_ (NULL_TREE, expr, 1);
12708
12709     case FFEBLD_opCONTER:
12710
12711       bt = ffeinfo_basictype (ffebld_info (expr));
12712       kt = ffeinfo_kindtype (ffebld_info (expr));
12713
12714       item = ffecom_constantunion (&ffebld_constant_union
12715                                    (ffebld_conter (expr)), bt, kt,
12716                                    ffecom_tree_type[bt][kt]);
12717       if (item == error_mark_node)
12718         return error_mark_node;
12719       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12720                        item);
12721       return item;
12722
12723     case FFEBLD_opANY:
12724       return error_mark_node;
12725
12726     default:
12727       bt = ffeinfo_basictype (ffebld_info (expr));
12728       kt = ffeinfo_kindtype (ffebld_info (expr));
12729
12730       item = ffecom_expr (expr);
12731       if (item == error_mark_node)
12732         return error_mark_node;
12733
12734       /* The back end currently optimizes a bit too zealously for us, in that
12735          we fail JCB001 if the following block of code is omitted.  It checks
12736          to see if the transformed expression is a symbol or array reference,
12737          and encloses it in a SAVE_EXPR if that is the case.  */
12738
12739       STRIP_NOPS (item);
12740       if ((TREE_CODE (item) == VAR_DECL)
12741           || (TREE_CODE (item) == PARM_DECL)
12742           || (TREE_CODE (item) == RESULT_DECL)
12743           || (TREE_CODE (item) == INDIRECT_REF)
12744           || (TREE_CODE (item) == ARRAY_REF)
12745           || (TREE_CODE (item) == COMPONENT_REF)
12746 #ifdef OFFSET_REF
12747           || (TREE_CODE (item) == OFFSET_REF)
12748 #endif
12749           || (TREE_CODE (item) == BUFFER_REF)
12750           || (TREE_CODE (item) == REALPART_EXPR)
12751           || (TREE_CODE (item) == IMAGPART_EXPR))
12752         {
12753           item = ffecom_save_tree (item);
12754         }
12755
12756       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12757                        item);
12758       return item;
12759     }
12760
12761   assert ("fall-through error" == NULL);
12762   return error_mark_node;
12763 }
12764
12765 #endif
12766 /* Obtain a temp var with given data type.
12767
12768    size is FFETARGET_charactersizeNONE for a non-CHARACTER type
12769    or >= 0 for a CHARACTER type.
12770
12771    elements is -1 for a scalar or > 0 for an array of type.  */
12772
12773 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12774 tree
12775 ffecom_make_tempvar (const char *commentary, tree type,
12776                      ffetargetCharacterSize size, int elements)
12777 {
12778   int yes;
12779   tree t;
12780   static int mynumber;
12781
12782   assert (current_binding_level->prep_state < 2);
12783
12784   if (type == error_mark_node)
12785     return error_mark_node;
12786
12787   yes = suspend_momentary ();
12788
12789   if (size != FFETARGET_charactersizeNONE)
12790     type = build_array_type (type,
12791                              build_range_type (ffecom_f2c_ftnlen_type_node,
12792                                                ffecom_f2c_ftnlen_one_node,
12793                                                build_int_2 (size, 0)));
12794   if (elements != -1)
12795     type = build_array_type (type,
12796                              build_range_type (integer_type_node,
12797                                                integer_zero_node,
12798                                                build_int_2 (elements - 1,
12799                                                             0)));
12800   t = build_decl (VAR_DECL,
12801                   ffecom_get_invented_identifier ("__g77_%s_%d",
12802                                                   commentary,
12803                                                   mynumber++),
12804                   type);
12805
12806   t = start_decl (t, FALSE);
12807   finish_decl (t, NULL_TREE, FALSE);
12808
12809   resume_momentary (yes);
12810
12811   return t;
12812 }
12813 #endif
12814
12815 /* Prepare argument pointer to expression.
12816
12817    Like ffecom_prepare_expr, except for expressions to be evaluated
12818    via ffecom_arg_ptr_to_expr.  */
12819
12820 void
12821 ffecom_prepare_arg_ptr_to_expr (ffebld expr)
12822 {
12823   /* ~~For now, it seems to be the same thing.  */
12824   ffecom_prepare_expr (expr);
12825   return;
12826 }
12827
12828 /* End of preparations.  */
12829
12830 bool
12831 ffecom_prepare_end (void)
12832 {
12833   int prep_state = current_binding_level->prep_state;
12834
12835   assert (prep_state < 2);
12836   current_binding_level->prep_state = 2;
12837
12838   return (prep_state == 1) ? TRUE : FALSE;
12839 }
12840
12841 /* Prepare expression.
12842
12843    This is called before any code is generated for the current block.
12844    It scans the expression, declares any temporaries that might be needed
12845    during evaluation of the expression, and stores those temporaries in
12846    the appropriate "hook" fields of the expression.  `dest', if not NULL,
12847    specifies the destination that ffecom_expr_ will see, in case that
12848    helps avoid generating unused temporaries.
12849
12850    ~~Improve to avoid allocating unused temporaries by taking `dest'
12851    into account vis-a-vis aliasing requirements of complex/character
12852    functions.  */
12853
12854 void
12855 ffecom_prepare_expr_ (ffebld expr, ffebld dest UNUSED)
12856 {
12857   ffeinfoBasictype bt;
12858   ffeinfoKindtype kt;
12859   ffetargetCharacterSize sz;
12860   tree tempvar = NULL_TREE;
12861
12862   assert (current_binding_level->prep_state < 2);
12863
12864   if (! expr)
12865     return;
12866
12867   bt = ffeinfo_basictype (ffebld_info (expr));
12868   kt = ffeinfo_kindtype (ffebld_info (expr));
12869   sz = ffeinfo_size (ffebld_info (expr));
12870
12871   /* Generate whatever temporaries are needed to represent the result
12872      of the expression.  */
12873
12874   if (bt == FFEINFO_basictypeCHARACTER)
12875     {
12876       while (ffebld_op (expr) == FFEBLD_opPAREN)
12877         expr = ffebld_left (expr);
12878     }
12879
12880   switch (ffebld_op (expr))
12881     {
12882     default:
12883       /* Don't make temps for SYMTER, CONTER, etc.  */
12884       if (ffebld_arity (expr) == 0)
12885         break;
12886
12887       switch (bt)
12888         {
12889         case FFEINFO_basictypeCOMPLEX:
12890           if (ffebld_op (expr) == FFEBLD_opFUNCREF)
12891             {
12892               ffesymbol s;
12893
12894               if (ffebld_op (ffebld_left (expr)) != FFEBLD_opSYMTER)
12895                 break;
12896
12897               s = ffebld_symter (ffebld_left (expr));
12898               if (ffesymbol_where (s) == FFEINFO_whereCONSTANT
12899                   || (ffesymbol_where (s) != FFEINFO_whereINTRINSIC
12900                       && ! ffesymbol_is_f2c (s))
12901                   || (ffesymbol_where (s) == FFEINFO_whereINTRINSIC
12902                       && ! ffe_is_f2c_library ()))
12903                 break;
12904             }
12905           else if (ffebld_op (expr) == FFEBLD_opPOWER)
12906             {
12907               /* Requires special treatment.  There's no POW_CC function
12908                  in libg2c, so POW_ZZ is used, which means we always
12909                  need a double-complex temp, not a single-complex.  */
12910               kt = FFEINFO_kindtypeREAL2;
12911             }
12912           else if (ffebld_op (expr) != FFEBLD_opDIVIDE)
12913             /* The other ops don't need temps for complex operands.  */
12914             break;
12915
12916           /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
12917              REAL(C).  See 19990325-0.f, routine `check', for cases.  */
12918           tempvar = ffecom_make_tempvar ("complex",
12919                                          ffecom_tree_type
12920                                          [FFEINFO_basictypeCOMPLEX][kt],
12921                                          FFETARGET_charactersizeNONE,
12922                                          -1);
12923           break;
12924
12925         case FFEINFO_basictypeCHARACTER:
12926           if (ffebld_op (expr) != FFEBLD_opFUNCREF)
12927             break;
12928
12929           if (sz == FFETARGET_charactersizeNONE)
12930             /* ~~Kludge alert!  This should someday be fixed. */
12931             sz = 24;
12932
12933           tempvar = ffecom_make_tempvar ("char", char_type_node, sz, -1);
12934           break;
12935
12936         default:
12937           break;
12938         }
12939       break;
12940
12941 #ifdef HAHA
12942     case FFEBLD_opPOWER:
12943       {
12944         tree rtype, ltype;
12945         tree rtmp, ltmp, result;
12946
12947         ltype = ffecom_type_expr (ffebld_left (expr));
12948         rtype = ffecom_type_expr (ffebld_right (expr));
12949
12950         rtmp = ffecom_make_tempvar (rtype, FFETARGET_charactersizeNONE, -1);
12951         ltmp = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12952         result = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12953
12954         tempvar = make_tree_vec (3);
12955         TREE_VEC_ELT (tempvar, 0) = rtmp;
12956         TREE_VEC_ELT (tempvar, 1) = ltmp;
12957         TREE_VEC_ELT (tempvar, 2) = result;
12958       }
12959       break;
12960 #endif  /* HAHA */
12961
12962     case FFEBLD_opCONCATENATE:
12963       {
12964         /* This gets special handling, because only one set of temps
12965            is needed for a tree of these -- the tree is treated as
12966            a flattened list of concatenations when generating code.  */
12967
12968         ffecomConcatList_ catlist;
12969         tree ltmp, itmp, result;
12970         int count;
12971         int i;
12972
12973         catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
12974         count = ffecom_concat_list_count_ (catlist);
12975
12976         if (count >= 2)
12977           {
12978             ltmp
12979               = ffecom_make_tempvar ("concat_len",
12980                                      ffecom_f2c_ftnlen_type_node,
12981                                      FFETARGET_charactersizeNONE, count);
12982             itmp
12983               = ffecom_make_tempvar ("concat_item",
12984                                      ffecom_f2c_address_type_node,
12985                                      FFETARGET_charactersizeNONE, count);
12986             result
12987               = ffecom_make_tempvar ("concat_res",
12988                                      char_type_node,
12989                                      ffecom_concat_list_maxlen_ (catlist),
12990                                      -1);
12991
12992             tempvar = make_tree_vec (3);
12993             TREE_VEC_ELT (tempvar, 0) = ltmp;
12994             TREE_VEC_ELT (tempvar, 1) = itmp;
12995             TREE_VEC_ELT (tempvar, 2) = result;
12996           }
12997
12998         for (i = 0; i < count; ++i)
12999           ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist,
13000                                                                     i));
13001
13002         ffecom_concat_list_kill_ (catlist);
13003
13004         if (tempvar)
13005           {
13006             ffebld_nonter_set_hook (expr, tempvar);
13007             current_binding_level->prep_state = 1;
13008           }
13009       }
13010       return;
13011
13012     case FFEBLD_opCONVERT:
13013       if (bt == FFEINFO_basictypeCHARACTER
13014           && ((ffebld_size_known (ffebld_left (expr))
13015                == FFETARGET_charactersizeNONE)
13016               || (ffebld_size_known (ffebld_left (expr)) >= sz)))
13017         tempvar = ffecom_make_tempvar ("convert", char_type_node, sz, -1);
13018       break;
13019     }
13020
13021   if (tempvar)
13022     {
13023       ffebld_nonter_set_hook (expr, tempvar);
13024       current_binding_level->prep_state = 1;
13025     }
13026
13027   /* Prepare subexpressions for this expr.  */
13028
13029   switch (ffebld_op (expr))
13030     {
13031     case FFEBLD_opPERCENT_LOC:
13032       ffecom_prepare_ptr_to_expr (ffebld_left (expr));
13033       break;
13034
13035     case FFEBLD_opPERCENT_VAL:
13036     case FFEBLD_opPERCENT_REF:
13037       ffecom_prepare_expr (ffebld_left (expr));
13038       break;
13039
13040     case FFEBLD_opPERCENT_DESCR:
13041       ffecom_prepare_arg_ptr_to_expr (ffebld_left (expr));
13042       break;
13043
13044     case FFEBLD_opITEM:
13045       {
13046         ffebld item;
13047
13048         for (item = expr;
13049              item != NULL;
13050              item = ffebld_trail (item))
13051           if (ffebld_head (item) != NULL)
13052             ffecom_prepare_expr (ffebld_head (item));
13053       }
13054       break;
13055
13056     default:
13057       /* Need to handle character conversion specially.  */
13058       switch (ffebld_arity (expr))
13059         {
13060         case 2:
13061           ffecom_prepare_expr (ffebld_left (expr));
13062           ffecom_prepare_expr (ffebld_right (expr));
13063           break;
13064
13065         case 1:
13066           ffecom_prepare_expr (ffebld_left (expr));
13067           break;
13068
13069         default:
13070           break;
13071         }
13072     }
13073
13074   return;
13075 }
13076
13077 /* Prepare expression for reading and writing.
13078
13079    Like ffecom_prepare_expr, except for expressions to be evaluated
13080    via ffecom_expr_rw.  */
13081
13082 void
13083 ffecom_prepare_expr_rw (tree type, ffebld expr)
13084 {
13085   /* This is all we support for now.  */
13086   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
13087
13088   /* ~~For now, it seems to be the same thing.  */
13089   ffecom_prepare_expr (expr);
13090   return;
13091 }
13092
13093 /* Prepare expression for writing.
13094
13095    Like ffecom_prepare_expr, except for expressions to be evaluated
13096    via ffecom_expr_w.  */
13097
13098 void
13099 ffecom_prepare_expr_w (tree type, ffebld expr)
13100 {
13101   /* This is all we support for now.  */
13102   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
13103
13104   /* ~~For now, it seems to be the same thing.  */
13105   ffecom_prepare_expr (expr);
13106   return;
13107 }
13108
13109 /* Prepare expression for returning.
13110
13111    Like ffecom_prepare_expr, except for expressions to be evaluated
13112    via ffecom_return_expr.  */
13113
13114 void
13115 ffecom_prepare_return_expr (ffebld expr)
13116 {
13117   assert (current_binding_level->prep_state < 2);
13118
13119   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE
13120       && ffecom_is_altreturning_
13121       && expr != NULL)
13122     ffecom_prepare_expr (expr);
13123 }
13124
13125 /* Prepare pointer to expression.
13126
13127    Like ffecom_prepare_expr, except for expressions to be evaluated
13128    via ffecom_ptr_to_expr.  */
13129
13130 void
13131 ffecom_prepare_ptr_to_expr (ffebld expr)
13132 {
13133   /* ~~For now, it seems to be the same thing.  */
13134   ffecom_prepare_expr (expr);
13135   return;
13136 }
13137
13138 /* Transform expression into constant pointer-to-expression tree.
13139
13140    If the expression can be transformed into a pointer-to-expression tree
13141    that is constant, that is done, and the tree returned.  Else NULL_TREE
13142    is returned.
13143
13144    That way, a caller can attempt to provide compile-time initialization
13145    of a variable and, if that fails, *then* choose to start a new block
13146    and resort to using temporaries, as appropriate.  */
13147
13148 tree
13149 ffecom_ptr_to_const_expr (ffebld expr)
13150 {
13151   if (! expr)
13152     return integer_zero_node;
13153
13154   if (ffebld_op (expr) == FFEBLD_opANY)
13155     return error_mark_node;
13156
13157   if (ffebld_arity (expr) == 0
13158       && (ffebld_op (expr) != FFEBLD_opSYMTER
13159           || ffebld_where (expr) == FFEINFO_whereCOMMON
13160           || ffebld_where (expr) == FFEINFO_whereGLOBAL
13161           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
13162     {
13163       tree t;
13164
13165       t = ffecom_ptr_to_expr (expr);
13166       assert (TREE_CONSTANT (t));
13167       return t;
13168     }
13169
13170   return NULL_TREE;
13171 }
13172
13173 /* ffecom_return_expr -- Returns return-value expr given alt return expr
13174
13175    tree rtn;  // NULL_TREE means use expand_null_return()
13176    ffebld expr;  // NULL if no alt return expr to RETURN stmt
13177    rtn = ffecom_return_expr(expr);
13178
13179    Based on the program unit type and other info (like return function
13180    type, return master function type when alternate ENTRY points,
13181    whether subroutine has any alternate RETURN points, etc), returns the
13182    appropriate expression to be returned to the caller, or NULL_TREE
13183    meaning no return value or the caller expects it to be returned somewhere
13184    else (which is handled by other parts of this module).  */
13185
13186 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13187 tree
13188 ffecom_return_expr (ffebld expr)
13189 {
13190   tree rtn;
13191
13192   switch (ffecom_primary_entry_kind_)
13193     {
13194     case FFEINFO_kindPROGRAM:
13195     case FFEINFO_kindBLOCKDATA:
13196       rtn = NULL_TREE;
13197       break;
13198
13199     case FFEINFO_kindSUBROUTINE:
13200       if (!ffecom_is_altreturning_)
13201         rtn = NULL_TREE;        /* No alt returns, never an expr. */
13202       else if (expr == NULL)
13203         rtn = integer_zero_node;
13204       else
13205         rtn = ffecom_expr (expr);
13206       break;
13207
13208     case FFEINFO_kindFUNCTION:
13209       if ((ffecom_multi_retval_ != NULL_TREE)
13210           || (ffesymbol_basictype (ffecom_primary_entry_)
13211               == FFEINFO_basictypeCHARACTER)
13212           || ((ffesymbol_basictype (ffecom_primary_entry_)
13213                == FFEINFO_basictypeCOMPLEX)
13214               && (ffecom_num_entrypoints_ == 0)
13215               && ffesymbol_is_f2c (ffecom_primary_entry_)))
13216         {                       /* Value is returned by direct assignment
13217                                    into (implicit) dummy. */
13218           rtn = NULL_TREE;
13219           break;
13220         }
13221       rtn = ffecom_func_result_;
13222 #if 0
13223       /* Spurious error if RETURN happens before first reference!  So elide
13224          this code.  In particular, for debugging registry, rtn should always
13225          be non-null after all, but TREE_USED won't be set until we encounter
13226          a reference in the code.  Perfectly okay (but weird) code that,
13227          e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
13228          this diagnostic for no reason.  Have people use -O -Wuninitialized
13229          and leave it to the back end to find obviously weird cases.  */
13230
13231       /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
13232          situation; if the return value has never been referenced, it won't
13233          have a tree under 2pass mode. */
13234       if ((rtn == NULL_TREE)
13235           || !TREE_USED (rtn))
13236         {
13237           ffebad_start (FFEBAD_RETURN_VALUE_UNSET);
13238           ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_),
13239                        ffesymbol_where_column (ffecom_primary_entry_));
13240           ffebad_string (ffesymbol_text (ffesymbol_funcresult
13241                                          (ffecom_primary_entry_)));
13242           ffebad_finish ();
13243         }
13244 #endif
13245       break;
13246
13247     default:
13248       assert ("bad unit kind" == NULL);
13249     case FFEINFO_kindANY:
13250       rtn = error_mark_node;
13251       break;
13252     }
13253
13254   return rtn;
13255 }
13256
13257 #endif
13258 /* Do save_expr only if tree is not error_mark_node.  */
13259
13260 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13261 tree
13262 ffecom_save_tree (tree t)
13263 {
13264   return save_expr (t);
13265 }
13266 #endif
13267
13268 /* Start a compound statement (block).  */
13269
13270 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13271 void
13272 ffecom_start_compstmt (void)
13273 {
13274   bison_rule_pushlevel_ ();
13275 }
13276 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
13277
13278 /* Public entry point for front end to access start_decl.  */
13279
13280 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13281 tree
13282 ffecom_start_decl (tree decl, bool is_initialized)
13283 {
13284   DECL_INITIAL (decl) = is_initialized ? error_mark_node : NULL_TREE;
13285   return start_decl (decl, FALSE);
13286 }
13287
13288 #endif
13289 /* ffecom_sym_commit -- Symbol's state being committed to reality
13290
13291    ffesymbol s;
13292    ffecom_sym_commit(s);
13293
13294    Does whatever the backend needs when a symbol is committed after having
13295    been backtrackable for a period of time.  */
13296
13297 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13298 void
13299 ffecom_sym_commit (ffesymbol s UNUSED)
13300 {
13301   assert (!ffesymbol_retractable ());
13302 }
13303
13304 #endif
13305 /* ffecom_sym_end_transition -- Perform end transition on all symbols
13306
13307    ffecom_sym_end_transition();
13308
13309    Does backend-specific stuff and also calls ffest_sym_end_transition
13310    to do the necessary FFE stuff.
13311
13312    Backtracking is never enabled when this fn is called, so don't worry
13313    about it.  */
13314
13315 ffesymbol
13316 ffecom_sym_end_transition (ffesymbol s)
13317 {
13318   ffestorag st;
13319
13320   assert (!ffesymbol_retractable ());
13321
13322   s = ffest_sym_end_transition (s);
13323
13324 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13325   if ((ffesymbol_kind (s) == FFEINFO_kindBLOCKDATA)
13326       && (ffesymbol_where (s) == FFEINFO_whereGLOBAL))
13327     {
13328       ffecom_list_blockdata_
13329         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
13330                                               FFEINTRIN_specNONE,
13331                                               FFEINTRIN_impNONE),
13332                            ffecom_list_blockdata_);
13333     }
13334 #endif
13335
13336   /* This is where we finally notice that a symbol has partial initialization
13337      and finalize it. */
13338
13339   if (ffesymbol_accretion (s) != NULL)
13340     {
13341       assert (ffesymbol_init (s) == NULL);
13342       ffecom_notify_init_symbol (s);
13343     }
13344   else if (((st = ffesymbol_storage (s)) != NULL)
13345            && ((st = ffestorag_parent (st)) != NULL)
13346            && (ffestorag_accretion (st) != NULL))
13347     {
13348       assert (ffestorag_init (st) == NULL);
13349       ffecom_notify_init_storage (st);
13350     }
13351
13352 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13353   if ((ffesymbol_kind (s) == FFEINFO_kindCOMMON)
13354       && (ffesymbol_where (s) == FFEINFO_whereLOCAL)
13355       && (ffesymbol_storage (s) != NULL))
13356     {
13357       ffecom_list_common_
13358         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
13359                                               FFEINTRIN_specNONE,
13360                                               FFEINTRIN_impNONE),
13361                            ffecom_list_common_);
13362     }
13363 #endif
13364
13365   return s;
13366 }
13367
13368 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
13369
13370    ffecom_sym_exec_transition();
13371
13372    Does backend-specific stuff and also calls ffest_sym_exec_transition
13373    to do the necessary FFE stuff.
13374
13375    See the long-winded description in ffecom_sym_learned for info
13376    on handling the situation where backtracking is inhibited.  */
13377
13378 ffesymbol
13379 ffecom_sym_exec_transition (ffesymbol s)
13380 {
13381   s = ffest_sym_exec_transition (s);
13382
13383   return s;
13384 }
13385
13386 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
13387
13388    ffesymbol s;
13389    s = ffecom_sym_learned(s);
13390
13391    Called when a new symbol is seen after the exec transition or when more
13392    info (perhaps) is gained for an UNCERTAIN symbol.  The symbol state when
13393    it arrives here is that all its latest info is updated already, so its
13394    state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
13395    field filled in if its gone through here or exec_transition first, and
13396    so on.
13397
13398    The backend probably wants to check ffesymbol_retractable() to see if
13399    backtracking is in effect.  If so, the FFE's changes to the symbol may
13400    be retracted (undone) or committed (ratified), at which time the
13401    appropriate ffecom_sym_retract or _commit function will be called
13402    for that function.
13403
13404    If the backend has its own backtracking mechanism, great, use it so that
13405    committal is a simple operation.  Though it doesn't make much difference,
13406    I suppose: the reason for tentative symbol evolution in the FFE is to
13407    enable error detection in weird incorrect statements early and to disable
13408    incorrect error detection on a correct statement.  The backend is not
13409    likely to introduce any information that'll get involved in these
13410    considerations, so it is probably just fine that the implementation
13411    model for this fn and for _exec_transition is to not do anything
13412    (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
13413    and instead wait until ffecom_sym_commit is called (which it never
13414    will be as long as we're using ambiguity-detecting statement analysis in
13415    the FFE, which we are initially to shake out the code, but don't depend
13416    on this), otherwise go ahead and do whatever is needed.
13417
13418    In essence, then, when this fn and _exec_transition get called while
13419    backtracking is enabled, a general mechanism would be to flag which (or
13420    both) of these were called (and in what order? neat question as to what
13421    might happen that I'm too lame to think through right now) and then when
13422    _commit is called reproduce the original calling sequence, if any, for
13423    the two fns (at which point backtracking will, of course, be disabled).  */
13424
13425 ffesymbol
13426 ffecom_sym_learned (ffesymbol s)
13427 {
13428   ffestorag_exec_layout (s);
13429
13430   return s;
13431 }
13432
13433 /* ffecom_sym_retract -- Symbol's state being retracted from reality
13434
13435    ffesymbol s;
13436    ffecom_sym_retract(s);
13437
13438    Does whatever the backend needs when a symbol is retracted after having
13439    been backtrackable for a period of time.  */
13440
13441 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13442 void
13443 ffecom_sym_retract (ffesymbol s UNUSED)
13444 {
13445   assert (!ffesymbol_retractable ());
13446
13447 #if 0                           /* GCC doesn't commit any backtrackable sins,
13448                                    so nothing needed here. */
13449   switch (ffesymbol_hook (s).state)
13450     {
13451     case 0:                     /* nothing happened yet. */
13452       break;
13453
13454     case 1:                     /* exec transition happened. */
13455       break;
13456
13457     case 2:                     /* learned happened. */
13458       break;
13459
13460     case 3:                     /* learned then exec. */
13461       break;
13462
13463     case 4:                     /* exec then learned. */
13464       break;
13465
13466     default:
13467       assert ("bad hook state" == NULL);
13468       break;
13469     }
13470 #endif
13471 }
13472
13473 #endif
13474 /* Create temporary gcc label.  */
13475
13476 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13477 tree
13478 ffecom_temp_label ()
13479 {
13480   tree glabel;
13481   static int mynumber = 0;
13482
13483   glabel = build_decl (LABEL_DECL,
13484                        ffecom_get_invented_identifier ("__g77_label_%d",
13485                                                        mynumber++),
13486                        void_type_node);
13487   DECL_CONTEXT (glabel) = current_function_decl;
13488   DECL_MODE (glabel) = VOIDmode;
13489
13490   return glabel;
13491 }
13492
13493 #endif
13494 /* Return an expression that is usable as an arg in a conditional context
13495    (IF, DO WHILE, .NOT., and so on).
13496
13497    Use the one provided for the back end as of >2.6.0.  */
13498
13499 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13500 tree
13501 ffecom_truth_value (tree expr)
13502 {
13503   return truthvalue_conversion (expr);
13504 }
13505
13506 #endif
13507 /* Return the inversion of a truth value (the inversion of what
13508    ffecom_truth_value builds).
13509
13510    Apparently invert_truthvalue, which is properly in the back end, is
13511    enough for now, so just use it.  */
13512
13513 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13514 tree
13515 ffecom_truth_value_invert (tree expr)
13516 {
13517   return invert_truthvalue (ffecom_truth_value (expr));
13518 }
13519
13520 #endif
13521
13522 /* Return the tree that is the type of the expression, as would be
13523    returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
13524    transforming the expression, generating temporaries, etc.  */
13525
13526 tree
13527 ffecom_type_expr (ffebld expr)
13528 {
13529   ffeinfoBasictype bt;
13530   ffeinfoKindtype kt;
13531   tree tree_type;
13532
13533   assert (expr != NULL);
13534
13535   bt = ffeinfo_basictype (ffebld_info (expr));
13536   kt = ffeinfo_kindtype (ffebld_info (expr));
13537   tree_type = ffecom_tree_type[bt][kt];
13538
13539   switch (ffebld_op (expr))
13540     {
13541     case FFEBLD_opCONTER:
13542     case FFEBLD_opSYMTER:
13543     case FFEBLD_opARRAYREF:
13544     case FFEBLD_opUPLUS:
13545     case FFEBLD_opPAREN:
13546     case FFEBLD_opUMINUS:
13547     case FFEBLD_opADD:
13548     case FFEBLD_opSUBTRACT:
13549     case FFEBLD_opMULTIPLY:
13550     case FFEBLD_opDIVIDE:
13551     case FFEBLD_opPOWER:
13552     case FFEBLD_opNOT:
13553     case FFEBLD_opFUNCREF:
13554     case FFEBLD_opSUBRREF:
13555     case FFEBLD_opAND:
13556     case FFEBLD_opOR:
13557     case FFEBLD_opXOR:
13558     case FFEBLD_opNEQV:
13559     case FFEBLD_opEQV:
13560     case FFEBLD_opCONVERT:
13561     case FFEBLD_opLT:
13562     case FFEBLD_opLE:
13563     case FFEBLD_opEQ:
13564     case FFEBLD_opNE:
13565     case FFEBLD_opGT:
13566     case FFEBLD_opGE:
13567     case FFEBLD_opPERCENT_LOC:
13568       return tree_type;
13569
13570     case FFEBLD_opACCTER:
13571     case FFEBLD_opARRTER:
13572     case FFEBLD_opITEM:
13573     case FFEBLD_opSTAR:
13574     case FFEBLD_opBOUNDS:
13575     case FFEBLD_opREPEAT:
13576     case FFEBLD_opLABTER:
13577     case FFEBLD_opLABTOK:
13578     case FFEBLD_opIMPDO:
13579     case FFEBLD_opCONCATENATE:
13580     case FFEBLD_opSUBSTR:
13581     default:
13582       assert ("bad op for ffecom_type_expr" == NULL);
13583       /* Fall through. */
13584     case FFEBLD_opANY:
13585       return error_mark_node;
13586     }
13587 }
13588
13589 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13590
13591    If the PARM_DECL already exists, return it, else create it.  It's an
13592    integer_type_node argument for the master function that implements a
13593    subroutine or function with more than one entrypoint and is bound at
13594    run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13595    first ENTRY statement, and so on).  */
13596
13597 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13598 tree
13599 ffecom_which_entrypoint_decl ()
13600 {
13601   assert (ffecom_which_entrypoint_decl_ != NULL_TREE);
13602
13603   return ffecom_which_entrypoint_decl_;
13604 }
13605
13606 #endif
13607 \f
13608 /* The following sections consists of private and public functions
13609    that have the same names and perform roughly the same functions
13610    as counterparts in the C front end.  Changes in the C front end
13611    might affect how things should be done here.  Only functions
13612    needed by the back end should be public here; the rest should
13613    be private (static in the C sense).  Functions needed by other
13614    g77 front-end modules should be accessed by them via public
13615    ffecom_* names, which should themselves call private versions
13616    in this section so the private versions are easy to recognize
13617    when upgrading to a new gcc and finding interesting changes
13618    in the front end.
13619
13620    Functions named after rule "foo:" in c-parse.y are named
13621    "bison_rule_foo_" so they are easy to find.  */
13622
13623 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13624
13625 static void
13626 bison_rule_pushlevel_ ()
13627 {
13628   emit_line_note (input_filename, lineno);
13629   pushlevel (0);
13630   clear_last_expr ();
13631   push_momentary ();
13632   expand_start_bindings (0);
13633 }
13634
13635 static tree
13636 bison_rule_compstmt_ ()
13637 {
13638   tree t;
13639   int keep = kept_level_p ();
13640
13641   /* Make the temps go away.  */
13642   if (! keep)
13643     current_binding_level->names = NULL_TREE;
13644
13645   emit_line_note (input_filename, lineno);
13646   expand_end_bindings (getdecls (), keep, 0);
13647   t = poplevel (keep, 1, 0);
13648   pop_momentary ();
13649
13650   return t;
13651 }
13652
13653 /* Return a definition for a builtin function named NAME and whose data type
13654    is TYPE.  TYPE should be a function type with argument types.
13655    FUNCTION_CODE tells later passes how to compile calls to this function.
13656    See tree.h for its possible values.
13657
13658    If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13659    the name to be called if we can't opencode the function.  */
13660
13661 tree
13662 builtin_function (const char *name, tree type, int function_code,
13663                   enum built_in_class class,
13664                   const char *library_name)
13665 {
13666   tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
13667   DECL_EXTERNAL (decl) = 1;
13668   TREE_PUBLIC (decl) = 1;
13669   if (library_name)
13670     DECL_ASSEMBLER_NAME (decl) = get_identifier (library_name);
13671   make_decl_rtl (decl, NULL_PTR, 1);
13672   pushdecl (decl);
13673   DECL_BUILT_IN_CLASS (decl) = class;
13674   DECL_FUNCTION_CODE (decl) = function_code;
13675
13676   return decl;
13677 }
13678
13679 /* Handle when a new declaration NEWDECL
13680    has the same name as an old one OLDDECL
13681    in the same binding contour.
13682    Prints an error message if appropriate.
13683
13684    If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13685    Otherwise, return 0.  */
13686
13687 static int
13688 duplicate_decls (tree newdecl, tree olddecl)
13689 {
13690   int types_match = 1;
13691   int new_is_definition = (TREE_CODE (newdecl) == FUNCTION_DECL
13692                            && DECL_INITIAL (newdecl) != 0);
13693   tree oldtype = TREE_TYPE (olddecl);
13694   tree newtype = TREE_TYPE (newdecl);
13695
13696   if (olddecl == newdecl)
13697     return 1;
13698
13699   if (TREE_CODE (newtype) == ERROR_MARK
13700       || TREE_CODE (oldtype) == ERROR_MARK)
13701     types_match = 0;
13702
13703   /* New decl is completely inconsistent with the old one =>
13704      tell caller to replace the old one.
13705      This is always an error except in the case of shadowing a builtin.  */
13706   if (TREE_CODE (olddecl) != TREE_CODE (newdecl))
13707     return 0;
13708
13709   /* For real parm decl following a forward decl,
13710      return 1 so old decl will be reused.  */
13711   if (types_match && TREE_CODE (newdecl) == PARM_DECL
13712       && TREE_ASM_WRITTEN (olddecl) && ! TREE_ASM_WRITTEN (newdecl))
13713     return 1;
13714
13715   /* The new declaration is the same kind of object as the old one.
13716      The declarations may partially match.  Print warnings if they don't
13717      match enough.  Ultimately, copy most of the information from the new
13718      decl to the old one, and keep using the old one.  */
13719
13720   if (TREE_CODE (olddecl) == FUNCTION_DECL
13721       && DECL_BUILT_IN (olddecl))
13722     {
13723       /* A function declaration for a built-in function.  */
13724       if (!TREE_PUBLIC (newdecl))
13725         return 0;
13726       else if (!types_match)
13727         {
13728           /* Accept the return type of the new declaration if same modes.  */
13729           tree oldreturntype = TREE_TYPE (TREE_TYPE (olddecl));
13730           tree newreturntype = TREE_TYPE (TREE_TYPE (newdecl));
13731
13732           if (TYPE_MODE (oldreturntype) == TYPE_MODE (newreturntype))
13733             {
13734               /* Function types may be shared, so we can't just modify
13735                  the return type of olddecl's function type.  */
13736               tree newtype
13737                 = build_function_type (newreturntype,
13738                                        TYPE_ARG_TYPES (TREE_TYPE (olddecl)));
13739
13740               types_match = 1;
13741               if (types_match)
13742                 TREE_TYPE (olddecl) = newtype;
13743             }
13744         }
13745       if (!types_match)
13746         return 0;
13747     }
13748   else if (TREE_CODE (olddecl) == FUNCTION_DECL
13749            && DECL_SOURCE_LINE (olddecl) == 0)
13750     {
13751       /* A function declaration for a predeclared function
13752          that isn't actually built in.  */
13753       if (!TREE_PUBLIC (newdecl))
13754         return 0;
13755       else if (!types_match)
13756         {
13757           /* If the types don't match, preserve volatility indication.
13758              Later on, we will discard everything else about the
13759              default declaration.  */
13760           TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl);
13761         }
13762     }
13763
13764   /* Copy all the DECL_... slots specified in the new decl
13765      except for any that we copy here from the old type.
13766
13767      Past this point, we don't change OLDTYPE and NEWTYPE
13768      even if we change the types of NEWDECL and OLDDECL.  */
13769
13770   if (types_match)
13771     {
13772       /* Merge the data types specified in the two decls.  */
13773       if (TREE_CODE (newdecl) != FUNCTION_DECL || !DECL_BUILT_IN (olddecl))
13774         TREE_TYPE (newdecl)
13775           = TREE_TYPE (olddecl)
13776             = TREE_TYPE (newdecl);
13777
13778       /* Lay the type out, unless already done.  */
13779       if (oldtype != TREE_TYPE (newdecl))
13780         {
13781           if (TREE_TYPE (newdecl) != error_mark_node)
13782             layout_type (TREE_TYPE (newdecl));
13783           if (TREE_CODE (newdecl) != FUNCTION_DECL
13784               && TREE_CODE (newdecl) != TYPE_DECL
13785               && TREE_CODE (newdecl) != CONST_DECL)
13786             layout_decl (newdecl, 0);
13787         }
13788       else
13789         {
13790           /* Since the type is OLDDECL's, make OLDDECL's size go with.  */
13791           DECL_SIZE (newdecl) = DECL_SIZE (olddecl);
13792           DECL_SIZE_UNIT (newdecl) = DECL_SIZE_UNIT (olddecl);
13793           if (TREE_CODE (olddecl) != FUNCTION_DECL)
13794             if (DECL_ALIGN (olddecl) > DECL_ALIGN (newdecl))
13795               {
13796                 DECL_ALIGN (newdecl) = DECL_ALIGN (olddecl);
13797                 DECL_USER_ALIGN (newdecl) |= DECL_USER_ALIGN (olddecl);
13798               }
13799         }
13800
13801       /* Keep the old rtl since we can safely use it.  */
13802       DECL_RTL (newdecl) = DECL_RTL (olddecl);
13803
13804       /* Merge the type qualifiers.  */
13805       if (DECL_BUILT_IN_NONANSI (olddecl) && TREE_THIS_VOLATILE (olddecl)
13806           && !TREE_THIS_VOLATILE (newdecl))
13807         TREE_THIS_VOLATILE (olddecl) = 0;
13808       if (TREE_READONLY (newdecl))
13809         TREE_READONLY (olddecl) = 1;
13810       if (TREE_THIS_VOLATILE (newdecl))
13811         {
13812           TREE_THIS_VOLATILE (olddecl) = 1;
13813           if (TREE_CODE (newdecl) == VAR_DECL)
13814             make_var_volatile (newdecl);
13815         }
13816
13817       /* Keep source location of definition rather than declaration.
13818          Likewise, keep decl at outer scope.  */
13819       if ((DECL_INITIAL (newdecl) == 0 && DECL_INITIAL (olddecl) != 0)
13820           || (DECL_CONTEXT (newdecl) != 0 && DECL_CONTEXT (olddecl) == 0))
13821         {
13822           DECL_SOURCE_LINE (newdecl) = DECL_SOURCE_LINE (olddecl);
13823           DECL_SOURCE_FILE (newdecl) = DECL_SOURCE_FILE (olddecl);
13824
13825           if (DECL_CONTEXT (olddecl) == 0
13826               && TREE_CODE (newdecl) != FUNCTION_DECL)
13827             DECL_CONTEXT (newdecl) = 0;
13828         }
13829
13830       /* Merge the unused-warning information.  */
13831       if (DECL_IN_SYSTEM_HEADER (olddecl))
13832         DECL_IN_SYSTEM_HEADER (newdecl) = 1;
13833       else if (DECL_IN_SYSTEM_HEADER (newdecl))
13834         DECL_IN_SYSTEM_HEADER (olddecl) = 1;
13835
13836       /* Merge the initialization information.  */
13837       if (DECL_INITIAL (newdecl) == 0)
13838         DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13839
13840       /* Merge the section attribute.
13841          We want to issue an error if the sections conflict but that must be
13842          done later in decl_attributes since we are called before attributes
13843          are assigned.  */
13844       if (DECL_SECTION_NAME (newdecl) == NULL_TREE)
13845         DECL_SECTION_NAME (newdecl) = DECL_SECTION_NAME (olddecl);
13846
13847 #if BUILT_FOR_270
13848       if (TREE_CODE (newdecl) == FUNCTION_DECL)
13849         {
13850           DECL_STATIC_CONSTRUCTOR(newdecl) |= DECL_STATIC_CONSTRUCTOR(olddecl);
13851           DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl);
13852         }
13853 #endif
13854     }
13855   /* If cannot merge, then use the new type and qualifiers,
13856      and don't preserve the old rtl.  */
13857   else
13858     {
13859       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13860       TREE_READONLY (olddecl) = TREE_READONLY (newdecl);
13861       TREE_THIS_VOLATILE (olddecl) = TREE_THIS_VOLATILE (newdecl);
13862       TREE_SIDE_EFFECTS (olddecl) = TREE_SIDE_EFFECTS (newdecl);
13863     }
13864
13865   /* Merge the storage class information.  */
13866   /* For functions, static overrides non-static.  */
13867   if (TREE_CODE (newdecl) == FUNCTION_DECL)
13868     {
13869       TREE_PUBLIC (newdecl) &= TREE_PUBLIC (olddecl);
13870       /* This is since we don't automatically
13871          copy the attributes of NEWDECL into OLDDECL.  */
13872       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13873       /* If this clears `static', clear it in the identifier too.  */
13874       if (! TREE_PUBLIC (olddecl))
13875         TREE_PUBLIC (DECL_NAME (olddecl)) = 0;
13876     }
13877   if (DECL_EXTERNAL (newdecl))
13878     {
13879       TREE_STATIC (newdecl) = TREE_STATIC (olddecl);
13880       DECL_EXTERNAL (newdecl) = DECL_EXTERNAL (olddecl);
13881       /* An extern decl does not override previous storage class.  */
13882       TREE_PUBLIC (newdecl) = TREE_PUBLIC (olddecl);
13883     }
13884   else
13885     {
13886       TREE_STATIC (olddecl) = TREE_STATIC (newdecl);
13887       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13888     }
13889
13890   /* If either decl says `inline', this fn is inline,
13891      unless its definition was passed already.  */
13892   if (DECL_INLINE (newdecl) && DECL_INITIAL (olddecl) == 0)
13893     DECL_INLINE (olddecl) = 1;
13894   DECL_INLINE (newdecl) = DECL_INLINE (olddecl);
13895
13896   /* Get rid of any built-in function if new arg types don't match it
13897      or if we have a function definition.  */
13898   if (TREE_CODE (newdecl) == FUNCTION_DECL
13899       && DECL_BUILT_IN (olddecl)
13900       && (!types_match || new_is_definition))
13901     {
13902       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13903       DECL_BUILT_IN_CLASS (olddecl) = NOT_BUILT_IN;
13904     }
13905
13906   /* If redeclaring a builtin function, and not a definition,
13907      it stays built in.
13908      Also preserve various other info from the definition.  */
13909   if (TREE_CODE (newdecl) == FUNCTION_DECL && !new_is_definition)
13910     {
13911       if (DECL_BUILT_IN (olddecl))
13912         {
13913           DECL_BUILT_IN_CLASS (newdecl) = DECL_BUILT_IN_CLASS (olddecl);
13914           DECL_FUNCTION_CODE (newdecl) = DECL_FUNCTION_CODE (olddecl);
13915         }
13916       else
13917         DECL_FRAME_SIZE (newdecl) = DECL_FRAME_SIZE (olddecl);
13918
13919       DECL_RESULT (newdecl) = DECL_RESULT (olddecl);
13920       DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13921       DECL_SAVED_INSNS (newdecl) = DECL_SAVED_INSNS (olddecl);
13922       DECL_ARGUMENTS (newdecl) = DECL_ARGUMENTS (olddecl);
13923     }
13924
13925   /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13926      But preserve olddecl's DECL_UID.  */
13927   {
13928     register unsigned olddecl_uid = DECL_UID (olddecl);
13929
13930     memcpy ((char *) olddecl + sizeof (struct tree_common),
13931             (char *) newdecl + sizeof (struct tree_common),
13932             sizeof (struct tree_decl) - sizeof (struct tree_common));
13933     DECL_UID (olddecl) = olddecl_uid;
13934   }
13935
13936   return 1;
13937 }
13938
13939 /* Finish processing of a declaration;
13940    install its initial value.
13941    If the length of an array type is not known before,
13942    it must be determined now, from the initial value, or it is an error.  */
13943
13944 static void
13945 finish_decl (tree decl, tree init, bool is_top_level)
13946 {
13947   register tree type = TREE_TYPE (decl);
13948   int was_incomplete = (DECL_SIZE (decl) == 0);
13949   int temporary = allocation_temporary_p ();
13950   bool at_top_level = (current_binding_level == global_binding_level);
13951   bool top_level = is_top_level || at_top_level;
13952
13953   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13954      level anyway.  */
13955   assert (!is_top_level || !at_top_level);
13956
13957   if (TREE_CODE (decl) == PARM_DECL)
13958     assert (init == NULL_TREE);
13959   /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
13960      overlaps DECL_ARG_TYPE.  */
13961   else if (init == NULL_TREE)
13962     assert (DECL_INITIAL (decl) == NULL_TREE);
13963   else
13964     assert (DECL_INITIAL (decl) == error_mark_node);
13965
13966   if (init != NULL_TREE)
13967     {
13968       if (TREE_CODE (decl) != TYPE_DECL)
13969         DECL_INITIAL (decl) = init;
13970       else
13971         {
13972           /* typedef foo = bar; store the type of bar as the type of foo.  */
13973           TREE_TYPE (decl) = TREE_TYPE (init);
13974           DECL_INITIAL (decl) = init = 0;
13975         }
13976     }
13977
13978   /* Pop back to the obstack that is current for this binding level. This is
13979      because MAXINDEX, rtl, etc. to be made below must go in the permanent
13980      obstack.  But don't discard the temporary data yet.  */
13981   pop_obstacks ();
13982
13983   /* Deduce size of array from initialization, if not already known */
13984
13985   if (TREE_CODE (type) == ARRAY_TYPE
13986       && TYPE_DOMAIN (type) == 0
13987       && TREE_CODE (decl) != TYPE_DECL)
13988     {
13989       assert (top_level);
13990       assert (was_incomplete);
13991
13992       layout_decl (decl, 0);
13993     }
13994
13995   if (TREE_CODE (decl) == VAR_DECL)
13996     {
13997       if (DECL_SIZE (decl) == NULL_TREE
13998           && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
13999         layout_decl (decl, 0);
14000
14001       if (DECL_SIZE (decl) == NULL_TREE
14002           && (TREE_STATIC (decl)
14003               ?
14004       /* A static variable with an incomplete type is an error if it is
14005          initialized. Also if it is not file scope. Otherwise, let it
14006          through, but if it is not `extern' then it may cause an error
14007          message later.  */
14008               (DECL_INITIAL (decl) != 0 || DECL_CONTEXT (decl) != 0)
14009               :
14010       /* An automatic variable with an incomplete type is an error.  */
14011               !DECL_EXTERNAL (decl)))
14012         {
14013           assert ("storage size not known" == NULL);
14014           abort ();
14015         }
14016
14017       if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
14018           && (DECL_SIZE (decl) != 0)
14019           && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
14020         {
14021           assert ("storage size not constant" == NULL);
14022           abort ();
14023         }
14024     }
14025
14026   /* Output the assembler code and/or RTL code for variables and functions,
14027      unless the type is an undefined structure or union. If not, it will get
14028      done when the type is completed.  */
14029
14030   if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL)
14031     {
14032       rest_of_decl_compilation (decl, NULL,
14033                                 DECL_CONTEXT (decl) == 0,
14034                                 0);
14035
14036       if (DECL_CONTEXT (decl) != 0)
14037         {
14038           /* Recompute the RTL of a local array now if it used to be an
14039              incomplete type.  */
14040           if (was_incomplete
14041               && !TREE_STATIC (decl) && !DECL_EXTERNAL (decl))
14042             {
14043               /* If we used it already as memory, it must stay in memory.  */
14044               TREE_ADDRESSABLE (decl) = TREE_USED (decl);
14045               /* If it's still incomplete now, no init will save it.  */
14046               if (DECL_SIZE (decl) == 0)
14047                 DECL_INITIAL (decl) = 0;
14048               expand_decl (decl);
14049             }
14050           /* Compute and store the initial value.  */
14051           if (TREE_CODE (decl) != FUNCTION_DECL)
14052             expand_decl_init (decl);
14053         }
14054     }
14055   else if (TREE_CODE (decl) == TYPE_DECL)
14056     {
14057       rest_of_decl_compilation (decl, NULL_PTR,
14058                                 DECL_CONTEXT (decl) == 0,
14059                                 0);
14060     }
14061
14062   if (!(TREE_CODE (decl) == FUNCTION_DECL && DECL_INLINE (decl))
14063       && temporary
14064   /* DECL_INITIAL is not defined in PARM_DECLs, since it shares space with
14065      DECL_ARG_TYPE.  */
14066       && TREE_CODE (decl) != PARM_DECL)
14067     {
14068       /* We need to remember that this array HAD an initialization, but
14069          discard the actual temporary nodes, since we can't have a permanent
14070          node keep pointing to them.  */
14071       /* We make an exception for inline functions, since it's normal for a
14072          local extern redeclaration of an inline function to have a copy of
14073          the top-level decl's DECL_INLINE.  */
14074       if ((DECL_INITIAL (decl) != 0)
14075           && (DECL_INITIAL (decl) != error_mark_node))
14076         {
14077           /* If this is a const variable, then preserve the
14078              initializer instead of discarding it so that we can optimize
14079              references to it.  */
14080           /* This test used to include TREE_STATIC, but this won't be set
14081              for function level initializers.  */
14082           if (TREE_READONLY (decl))
14083             {
14084               preserve_initializer ();
14085
14086               /* The initializer and DECL must have the same (or equivalent
14087                  types), but if the initializer is a STRING_CST, its type
14088                  might not be on the right obstack, so copy the type
14089                  of DECL.  */
14090               TREE_TYPE (DECL_INITIAL (decl)) = type;
14091             }
14092           else
14093             DECL_INITIAL (decl) = error_mark_node;
14094         }
14095     }
14096
14097   /* If we have gone back from temporary to permanent allocation, actually
14098      free the temporary space that we no longer need.  */
14099   if (temporary && !allocation_temporary_p ())
14100     permanent_allocation (0);
14101
14102   /* At the end of a declaration, throw away any variable type sizes of types
14103      defined inside that declaration.  There is no use computing them in the
14104      following function definition.  */
14105   if (current_binding_level == global_binding_level)
14106     get_pending_sizes ();
14107 }
14108
14109 /* Finish up a function declaration and compile that function
14110    all the way to assembler language output.  The free the storage
14111    for the function definition.
14112
14113    This is called after parsing the body of the function definition.
14114
14115    NESTED is nonzero if the function being finished is nested in another.  */
14116
14117 static void
14118 finish_function (int nested)
14119 {
14120   register tree fndecl = current_function_decl;
14121
14122   assert (fndecl != NULL_TREE);
14123   if (TREE_CODE (fndecl) != ERROR_MARK)
14124     {
14125       if (nested)
14126         assert (DECL_CONTEXT (fndecl) != NULL_TREE);
14127       else
14128         assert (DECL_CONTEXT (fndecl) == NULL_TREE);
14129     }
14130
14131 /*  TREE_READONLY (fndecl) = 1;
14132     This caused &foo to be of type ptr-to-const-function
14133     which then got a warning when stored in a ptr-to-function variable.  */
14134
14135   poplevel (1, 0, 1);
14136
14137   if (TREE_CODE (fndecl) != ERROR_MARK)
14138     {
14139       BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
14140
14141       /* Must mark the RESULT_DECL as being in this function.  */
14142
14143       DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
14144
14145       /* Obey `register' declarations if `setjmp' is called in this fn.  */
14146       /* Generate rtl for function exit.  */
14147       expand_function_end (input_filename, lineno, 0);
14148
14149       /* So we can tell if jump_optimize sets it to 1.  */
14150       can_reach_end = 0;
14151
14152       /* If this is a nested function, protect the local variables in the stack
14153          above us from being collected while we're compiling this function.  */
14154       if (ggc_p && nested)
14155         ggc_push_context ();
14156
14157       /* Run the optimizers and output the assembler code for this function.  */
14158       rest_of_compilation (fndecl);
14159
14160       /* Undo the GC context switch.  */
14161       if (ggc_p && nested)
14162         ggc_pop_context ();
14163     }
14164
14165   /* Free all the tree nodes making up this function.  */
14166   /* Switch back to allocating nodes permanently until we start another
14167      function.  */
14168   if (!nested)
14169     permanent_allocation (1);
14170
14171   if (TREE_CODE (fndecl) != ERROR_MARK
14172       && !nested
14173       && DECL_SAVED_INSNS (fndecl) == 0)
14174     {
14175       /* Stop pointing to the local nodes about to be freed.  */
14176       /* But DECL_INITIAL must remain nonzero so we know this was an actual
14177          function definition.  */
14178       /* For a nested function, this is done in pop_f_function_context.  */
14179       /* If rest_of_compilation set this to 0, leave it 0.  */
14180       if (DECL_INITIAL (fndecl) != 0)
14181         DECL_INITIAL (fndecl) = error_mark_node;
14182       DECL_ARGUMENTS (fndecl) = 0;
14183     }
14184
14185   if (!nested)
14186     {
14187       /* Let the error reporting routines know that we're outside a function.
14188          For a nested function, this value is used in pop_c_function_context
14189          and then reset via pop_function_context.  */
14190       ffecom_outer_function_decl_ = current_function_decl = NULL;
14191     }
14192 }
14193
14194 /* Plug-in replacement for identifying the name of a decl and, for a
14195    function, what we call it in diagnostics.  For now, "program unit"
14196    should suffice, since it's a bit of a hassle to figure out which
14197    of several kinds of things it is.  Note that it could conceivably
14198    be a statement function, which probably isn't really a program unit
14199    per se, but if that comes up, it should be easy to check (being a
14200    nested function and all).  */
14201
14202 static const char *
14203 lang_printable_name (tree decl, int v)
14204 {
14205   /* Just to keep GCC quiet about the unused variable.
14206      In theory, differing values of V should produce different
14207      output.  */
14208   switch (v)
14209     {
14210     default:
14211       if (TREE_CODE (decl) == ERROR_MARK)
14212         return "erroneous code";
14213       return IDENTIFIER_POINTER (DECL_NAME (decl));
14214     }
14215 }
14216
14217 /* g77's function to print out name of current function that caused
14218    an error.  */
14219
14220 #if BUILT_FOR_270
14221 static void
14222 lang_print_error_function (const char *file)
14223 {
14224   static ffeglobal last_g = NULL;
14225   static ffesymbol last_s = NULL;
14226   ffeglobal g;
14227   ffesymbol s;
14228   const char *kind;
14229
14230   if ((ffecom_primary_entry_ == NULL)
14231       || (ffesymbol_global (ffecom_primary_entry_) == NULL))
14232     {
14233       g = NULL;
14234       s = NULL;
14235       kind = NULL;
14236     }
14237   else
14238     {
14239       g = ffesymbol_global (ffecom_primary_entry_);
14240       if (ffecom_nested_entry_ == NULL)
14241         {
14242           s = ffecom_primary_entry_;
14243           switch (ffesymbol_kind (s))
14244             {
14245             case FFEINFO_kindFUNCTION:
14246               kind = "function";
14247               break;
14248
14249             case FFEINFO_kindSUBROUTINE:
14250               kind = "subroutine";
14251               break;
14252
14253             case FFEINFO_kindPROGRAM:
14254               kind = "program";
14255               break;
14256
14257             case FFEINFO_kindBLOCKDATA:
14258               kind = "block-data";
14259               break;
14260
14261             default:
14262               kind = ffeinfo_kind_message (ffesymbol_kind (s));
14263               break;
14264             }
14265         }
14266       else
14267         {
14268           s = ffecom_nested_entry_;
14269           kind = "statement function";
14270         }
14271     }
14272
14273   if ((last_g != g) || (last_s != s))
14274     {
14275       if (file)
14276         fprintf (stderr, "%s: ", file);
14277
14278       if (s == NULL)
14279         fprintf (stderr, "Outside of any program unit:\n");
14280       else
14281         {
14282           const char *name = ffesymbol_text (s);
14283
14284           fprintf (stderr, "In %s `%s':\n", kind, name);
14285         }
14286
14287       last_g = g;
14288       last_s = s;
14289     }
14290 }
14291 #endif
14292
14293 /* Similar to `lookup_name' but look only at current binding level.  */
14294
14295 static tree
14296 lookup_name_current_level (tree name)
14297 {
14298   register tree t;
14299
14300   if (current_binding_level == global_binding_level)
14301     return IDENTIFIER_GLOBAL_VALUE (name);
14302
14303   if (IDENTIFIER_LOCAL_VALUE (name) == 0)
14304     return 0;
14305
14306   for (t = current_binding_level->names; t; t = TREE_CHAIN (t))
14307     if (DECL_NAME (t) == name)
14308       break;
14309
14310   return t;
14311 }
14312
14313 /* Create a new `struct binding_level'.  */
14314
14315 static struct binding_level *
14316 make_binding_level ()
14317 {
14318   /* NOSTRICT */
14319   return (struct binding_level *) xmalloc (sizeof (struct binding_level));
14320 }
14321
14322 /* Save and restore the variables in this file and elsewhere
14323    that keep track of the progress of compilation of the current function.
14324    Used for nested functions.  */
14325
14326 struct f_function
14327 {
14328   struct f_function *next;
14329   tree named_labels;
14330   tree shadowed_labels;
14331   struct binding_level *binding_level;
14332 };
14333
14334 struct f_function *f_function_chain;
14335
14336 /* Restore the variables used during compilation of a C function.  */
14337
14338 static void
14339 pop_f_function_context ()
14340 {
14341   struct f_function *p = f_function_chain;
14342   tree link;
14343
14344   /* Bring back all the labels that were shadowed.  */
14345   for (link = shadowed_labels; link; link = TREE_CHAIN (link))
14346     if (DECL_NAME (TREE_VALUE (link)) != 0)
14347       IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link)))
14348         = TREE_VALUE (link);
14349
14350   if (current_function_decl != error_mark_node
14351       && DECL_SAVED_INSNS (current_function_decl) == 0)
14352     {
14353       /* Stop pointing to the local nodes about to be freed.  */
14354       /* But DECL_INITIAL must remain nonzero so we know this was an actual
14355          function definition.  */
14356       DECL_INITIAL (current_function_decl) = error_mark_node;
14357       DECL_ARGUMENTS (current_function_decl) = 0;
14358     }
14359
14360   pop_function_context ();
14361
14362   f_function_chain = p->next;
14363
14364   named_labels = p->named_labels;
14365   shadowed_labels = p->shadowed_labels;
14366   current_binding_level = p->binding_level;
14367
14368   free (p);
14369 }
14370
14371 /* Save and reinitialize the variables
14372    used during compilation of a C function.  */
14373
14374 static void
14375 push_f_function_context ()
14376 {
14377   struct f_function *p
14378   = (struct f_function *) xmalloc (sizeof (struct f_function));
14379
14380   push_function_context ();
14381
14382   p->next = f_function_chain;
14383   f_function_chain = p;
14384
14385   p->named_labels = named_labels;
14386   p->shadowed_labels = shadowed_labels;
14387   p->binding_level = current_binding_level;
14388 }
14389
14390 static void
14391 push_parm_decl (tree parm)
14392 {
14393   int old_immediate_size_expand = immediate_size_expand;
14394
14395   /* Don't try computing parm sizes now -- wait till fn is called.  */
14396
14397   immediate_size_expand = 0;
14398
14399   push_obstacks_nochange ();
14400
14401   /* Fill in arg stuff.  */
14402
14403   DECL_ARG_TYPE (parm) = TREE_TYPE (parm);
14404   DECL_ARG_TYPE_AS_WRITTEN (parm) = TREE_TYPE (parm);
14405   TREE_READONLY (parm) = 1;     /* All implementation args are read-only. */
14406
14407   parm = pushdecl (parm);
14408
14409   immediate_size_expand = old_immediate_size_expand;
14410
14411   finish_decl (parm, NULL_TREE, FALSE);
14412 }
14413
14414 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate.  */
14415
14416 static tree
14417 pushdecl_top_level (x)
14418      tree x;
14419 {
14420   register tree t;
14421   register struct binding_level *b = current_binding_level;
14422   register tree f = current_function_decl;
14423
14424   current_binding_level = global_binding_level;
14425   current_function_decl = NULL_TREE;
14426   t = pushdecl (x);
14427   current_binding_level = b;
14428   current_function_decl = f;
14429   return t;
14430 }
14431
14432 /* Store the list of declarations of the current level.
14433    This is done for the parameter declarations of a function being defined,
14434    after they are modified in the light of any missing parameters.  */
14435
14436 static tree
14437 storedecls (decls)
14438      tree decls;
14439 {
14440   return current_binding_level->names = decls;
14441 }
14442
14443 /* Store the parameter declarations into the current function declaration.
14444    This is called after parsing the parameter declarations, before
14445    digesting the body of the function.
14446
14447    For an old-style definition, modify the function's type
14448    to specify at least the number of arguments.  */
14449
14450 static void
14451 store_parm_decls (int is_main_program UNUSED)
14452 {
14453   register tree fndecl = current_function_decl;
14454
14455   if (fndecl == error_mark_node)
14456     return;
14457
14458   /* This is a chain of PARM_DECLs from old-style parm declarations.  */
14459   DECL_ARGUMENTS (fndecl) = storedecls (nreverse (getdecls ()));
14460
14461   /* Initialize the RTL code for the function.  */
14462
14463   init_function_start (fndecl, input_filename, lineno);
14464
14465   /* Set up parameters and prepare for return, for the function.  */
14466
14467   expand_function_start (fndecl, 0);
14468 }
14469
14470 static tree
14471 start_decl (tree decl, bool is_top_level)
14472 {
14473   register tree tem;
14474   bool at_top_level = (current_binding_level == global_binding_level);
14475   bool top_level = is_top_level || at_top_level;
14476
14477   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
14478      level anyway.  */
14479   assert (!is_top_level || !at_top_level);
14480
14481   /* The corresponding pop_obstacks is in finish_decl.  */
14482   push_obstacks_nochange ();
14483
14484   if (DECL_INITIAL (decl) != NULL_TREE)
14485     {
14486       assert (DECL_INITIAL (decl) == error_mark_node);
14487       assert (!DECL_EXTERNAL (decl));
14488     }
14489   else if (top_level)
14490     assert ((TREE_STATIC (decl) == 1) || DECL_EXTERNAL (decl) == 1);
14491
14492   /* For Fortran, we by default put things in .common when possible.  */
14493   DECL_COMMON (decl) = 1;
14494
14495   /* Add this decl to the current binding level. TEM may equal DECL or it may
14496      be a previous decl of the same name.  */
14497   if (is_top_level)
14498     tem = pushdecl_top_level (decl);
14499   else
14500     tem = pushdecl (decl);
14501
14502   /* For a local variable, define the RTL now.  */
14503   if (!top_level
14504   /* But not if this is a duplicate decl and we preserved the rtl from the
14505      previous one (which may or may not happen).  */
14506       && DECL_RTL (tem) == 0)
14507     {
14508       if (TYPE_SIZE (TREE_TYPE (tem)) != 0)
14509         expand_decl (tem);
14510       else if (TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE
14511                && DECL_INITIAL (tem) != 0)
14512         expand_decl (tem);
14513     }
14514
14515   if (DECL_INITIAL (tem) != NULL_TREE)
14516     {
14517       /* When parsing and digesting the initializer, use temporary storage.
14518          Do this even if we will ignore the value.  */
14519       if (at_top_level)
14520         temporary_allocation ();
14521     }
14522
14523   return tem;
14524 }
14525
14526 /* Create the FUNCTION_DECL for a function definition.
14527    DECLSPECS and DECLARATOR are the parts of the declaration;
14528    they describe the function's name and the type it returns,
14529    but twisted together in a fashion that parallels the syntax of C.
14530
14531    This function creates a binding context for the function body
14532    as well as setting up the FUNCTION_DECL in current_function_decl.
14533
14534    Returns 1 on success.  If the DECLARATOR is not suitable for a function
14535    (it defines a datum instead), we return 0, which tells
14536    yyparse to report a parse error.
14537
14538    NESTED is nonzero for a function nested within another function.  */
14539
14540 static void
14541 start_function (tree name, tree type, int nested, int public)
14542 {
14543   tree decl1;
14544   tree restype;
14545   int old_immediate_size_expand = immediate_size_expand;
14546
14547   named_labels = 0;
14548   shadowed_labels = 0;
14549
14550   /* Don't expand any sizes in the return type of the function.  */
14551   immediate_size_expand = 0;
14552
14553   if (nested)
14554     {
14555       assert (!public);
14556       assert (current_function_decl != NULL_TREE);
14557       assert (DECL_CONTEXT (current_function_decl) == NULL_TREE);
14558     }
14559   else
14560     {
14561       assert (current_function_decl == NULL_TREE);
14562     }
14563
14564   if (TREE_CODE (type) == ERROR_MARK)
14565     decl1 = current_function_decl = error_mark_node;
14566   else
14567     {
14568       decl1 = build_decl (FUNCTION_DECL,
14569                           name,
14570                           type);
14571       TREE_PUBLIC (decl1) = public ? 1 : 0;
14572       if (nested)
14573         DECL_INLINE (decl1) = 1;
14574       TREE_STATIC (decl1) = 1;
14575       DECL_EXTERNAL (decl1) = 0;
14576
14577       announce_function (decl1);
14578
14579       /* Make the init_value nonzero so pushdecl knows this is not tentative.
14580          error_mark_node is replaced below (in poplevel) with the BLOCK.  */
14581       DECL_INITIAL (decl1) = error_mark_node;
14582
14583       /* Record the decl so that the function name is defined. If we already have
14584          a decl for this name, and it is a FUNCTION_DECL, use the old decl.  */
14585
14586       current_function_decl = pushdecl (decl1);
14587     }
14588
14589   if (!nested)
14590     ffecom_outer_function_decl_ = current_function_decl;
14591
14592   pushlevel (0);
14593   current_binding_level->prep_state = 2;
14594
14595   if (TREE_CODE (current_function_decl) != ERROR_MARK)
14596     {
14597       make_function_rtl (current_function_decl);
14598
14599       restype = TREE_TYPE (TREE_TYPE (current_function_decl));
14600       DECL_RESULT (current_function_decl)
14601         = build_decl (RESULT_DECL, NULL_TREE, restype);
14602     }
14603
14604   if (!nested)
14605     /* Allocate further tree nodes temporarily during compilation of this
14606        function only.  */
14607     temporary_allocation ();
14608
14609   if (!nested && (TREE_CODE (current_function_decl) != ERROR_MARK))
14610     TREE_ADDRESSABLE (current_function_decl) = 1;
14611
14612   immediate_size_expand = old_immediate_size_expand;
14613 }
14614 \f
14615 /* Here are the public functions the GNU back end needs.  */
14616
14617 tree
14618 convert (type, expr)
14619      tree type, expr;
14620 {
14621   register tree e = expr;
14622   register enum tree_code code = TREE_CODE (type);
14623
14624   if (type == TREE_TYPE (e)
14625       || TREE_CODE (e) == ERROR_MARK)
14626     return e;
14627   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
14628     return fold (build1 (NOP_EXPR, type, e));
14629   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
14630       || code == ERROR_MARK)
14631     return error_mark_node;
14632   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
14633     {
14634       assert ("void value not ignored as it ought to be" == NULL);
14635       return error_mark_node;
14636     }
14637   if (code == VOID_TYPE)
14638     return build1 (CONVERT_EXPR, type, e);
14639   if ((code != RECORD_TYPE)
14640       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
14641     e = ffecom_1 (REALPART_EXPR, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))),
14642                   e);
14643   if (code == INTEGER_TYPE || code == ENUMERAL_TYPE)
14644     return fold (convert_to_integer (type, e));
14645   if (code == POINTER_TYPE)
14646     return fold (convert_to_pointer (type, e));
14647   if (code == REAL_TYPE)
14648     return fold (convert_to_real (type, e));
14649   if (code == COMPLEX_TYPE)
14650     return fold (convert_to_complex (type, e));
14651   if (code == RECORD_TYPE)
14652     return fold (ffecom_convert_to_complex_ (type, e));
14653
14654   assert ("conversion to non-scalar type requested" == NULL);
14655   return error_mark_node;
14656 }
14657
14658 /* integrate_decl_tree calls this function, but since we don't use the
14659    DECL_LANG_SPECIFIC field, this is a no-op.  */
14660
14661 void
14662 copy_lang_decl (node)
14663      tree node UNUSED;
14664 {
14665 }
14666
14667 /* Return the list of declarations of the current level.
14668    Note that this list is in reverse order unless/until
14669    you nreverse it; and when you do nreverse it, you must
14670    store the result back using `storedecls' or you will lose.  */
14671
14672 tree
14673 getdecls ()
14674 {
14675   return current_binding_level->names;
14676 }
14677
14678 /* Nonzero if we are currently in the global binding level.  */
14679
14680 int
14681 global_bindings_p ()
14682 {
14683   return current_binding_level == global_binding_level;
14684 }
14685
14686 /* Print an error message for invalid use of an incomplete type.
14687    VALUE is the expression that was used (or 0 if that isn't known)
14688    and TYPE is the type that was invalid.  */
14689
14690 void
14691 incomplete_type_error (value, type)
14692      tree value UNUSED;
14693      tree type;
14694 {
14695   if (TREE_CODE (type) == ERROR_MARK)
14696     return;
14697
14698   assert ("incomplete type?!?" == NULL);
14699 }
14700
14701 /* Mark ARG for GC.  */
14702 static void
14703 mark_binding_level (void *arg)
14704 {
14705   struct binding_level *level = *(struct binding_level **) arg;
14706
14707   while (level)
14708     {
14709       ggc_mark_tree (level->names);
14710       ggc_mark_tree (level->blocks);
14711       ggc_mark_tree (level->this_block);
14712       level = level->level_chain;
14713     }
14714 }
14715
14716 void
14717 init_decl_processing ()
14718 {
14719   static tree *const tree_roots[] = {
14720     &current_function_decl,
14721     &string_type_node,
14722     &ffecom_tree_fun_type_void,
14723     &ffecom_integer_zero_node,
14724     &ffecom_integer_one_node,
14725     &ffecom_tree_subr_type,
14726     &ffecom_tree_ptr_to_subr_type,
14727     &ffecom_tree_blockdata_type,
14728     &ffecom_tree_xargc_,
14729     &ffecom_f2c_integer_type_node,
14730     &ffecom_f2c_ptr_to_integer_type_node,
14731     &ffecom_f2c_address_type_node,
14732     &ffecom_f2c_real_type_node,
14733     &ffecom_f2c_ptr_to_real_type_node,
14734     &ffecom_f2c_doublereal_type_node,
14735     &ffecom_f2c_complex_type_node,
14736     &ffecom_f2c_doublecomplex_type_node,
14737     &ffecom_f2c_longint_type_node,
14738     &ffecom_f2c_logical_type_node,
14739     &ffecom_f2c_flag_type_node,
14740     &ffecom_f2c_ftnlen_type_node,
14741     &ffecom_f2c_ftnlen_zero_node,
14742     &ffecom_f2c_ftnlen_one_node,
14743     &ffecom_f2c_ftnlen_two_node,
14744     &ffecom_f2c_ptr_to_ftnlen_type_node,
14745     &ffecom_f2c_ftnint_type_node,
14746     &ffecom_f2c_ptr_to_ftnint_type_node,
14747     &ffecom_outer_function_decl_,
14748     &ffecom_previous_function_decl_,
14749     &ffecom_which_entrypoint_decl_,
14750     &ffecom_float_zero_,
14751     &ffecom_float_half_,
14752     &ffecom_double_zero_,
14753     &ffecom_double_half_,
14754     &ffecom_func_result_,
14755     &ffecom_func_length_,
14756     &ffecom_multi_type_node_,
14757     &ffecom_multi_retval_,
14758     &named_labels,
14759     &shadowed_labels
14760   };
14761   size_t i;
14762
14763   malloc_init ();
14764
14765   /* Record our roots.  */
14766   for (i = 0; i < sizeof(tree_roots)/sizeof(tree_roots[0]); i++)
14767     ggc_add_tree_root (tree_roots[i], 1);
14768   ggc_add_tree_root (&ffecom_tree_type[0][0],
14769                      FFEINFO_basictype*FFEINFO_kindtype);
14770   ggc_add_tree_root (&ffecom_tree_fun_type[0][0],
14771                      FFEINFO_basictype*FFEINFO_kindtype);
14772   ggc_add_tree_root (&ffecom_tree_ptr_to_fun_type[0][0],
14773                      FFEINFO_basictype*FFEINFO_kindtype);
14774   ggc_add_tree_root (ffecom_gfrt_, FFECOM_gfrt);
14775   ggc_add_root (&current_binding_level, 1, sizeof current_binding_level,
14776                 mark_binding_level);
14777   ggc_add_root (&free_binding_level, 1, sizeof current_binding_level,
14778                 mark_binding_level);
14779   ggc_add_root (&tracker_head, 1, sizeof tracker_head, mark_tracker_head);
14780
14781   ffe_init_0 ();
14782 }
14783
14784 const char *
14785 init_parse (filename)
14786      const char *filename;
14787 {
14788   /* Open input file.  */
14789   if (filename == 0 || !strcmp (filename, "-"))
14790     {
14791       finput = stdin;
14792       filename = "stdin";
14793     }
14794   else
14795     finput = fopen (filename, "r");
14796   if (finput == 0)
14797     pfatal_with_name (filename);
14798
14799 #ifdef IO_BUFFER_SIZE
14800   setvbuf (finput, (char *) xmalloc (IO_BUFFER_SIZE), _IOFBF, IO_BUFFER_SIZE);
14801 #endif
14802
14803   /* Make identifier nodes long enough for the language-specific slots.  */
14804   set_identifier_size (sizeof (struct lang_identifier));
14805   decl_printable_name = lang_printable_name;
14806 #if BUILT_FOR_270
14807   print_error_function = lang_print_error_function;
14808 #endif
14809
14810   return filename;
14811 }
14812
14813 void
14814 finish_parse ()
14815 {
14816   fclose (finput);
14817 }
14818
14819 /* Delete the node BLOCK from the current binding level.
14820    This is used for the block inside a stmt expr ({...})
14821    so that the block can be reinserted where appropriate.  */
14822
14823 static void
14824 delete_block (block)
14825      tree block;
14826 {
14827   tree t;
14828   if (current_binding_level->blocks == block)
14829     current_binding_level->blocks = TREE_CHAIN (block);
14830   for (t = current_binding_level->blocks; t;)
14831     {
14832       if (TREE_CHAIN (t) == block)
14833         TREE_CHAIN (t) = TREE_CHAIN (block);
14834       else
14835         t = TREE_CHAIN (t);
14836     }
14837   TREE_CHAIN (block) = NULL;
14838   /* Clear TREE_USED which is always set by poplevel.
14839      The flag is set again if insert_block is called.  */
14840   TREE_USED (block) = 0;
14841 }
14842
14843 void
14844 insert_block (block)
14845      tree block;
14846 {
14847   TREE_USED (block) = 1;
14848   current_binding_level->blocks
14849     = chainon (current_binding_level->blocks, block);
14850 }
14851
14852 int
14853 lang_decode_option (argc, argv)
14854      int argc;
14855      char **argv;
14856 {
14857   return ffe_decode_option (argc, argv);
14858 }
14859
14860 /* used by print-tree.c */
14861
14862 void
14863 lang_print_xnode (file, node, indent)
14864      FILE *file UNUSED;
14865      tree node UNUSED;
14866      int indent UNUSED;
14867 {
14868 }
14869
14870 void
14871 lang_finish ()
14872 {
14873   ffe_terminate_0 ();
14874
14875   if (ffe_is_ffedebug ())
14876     malloc_pool_display (malloc_pool_image ());
14877 }
14878
14879 const char *
14880 lang_identify ()
14881 {
14882   return "f77";
14883 }
14884
14885 /* Return the typed-based alias set for T, which may be an expression
14886    or a type.  Return -1 if we don't do anything special.  */
14887
14888 HOST_WIDE_INT
14889 lang_get_alias_set (t)
14890      tree t ATTRIBUTE_UNUSED;
14891 {
14892   /* We do not wish to use alias-set based aliasing at all.  Used in the
14893      extreme (every object with its own set, with equivalences recorded)
14894      it might be helpful, but there are problems when it comes to inlining.
14895      We get on ok with flag_argument_noalias, and alias-set aliasing does
14896      currently limit how stack slots can be reused, which is a lose.  */
14897   return 0;
14898 }
14899
14900 void
14901 lang_init_options ()
14902 {
14903   /* Set default options for Fortran.  */
14904   flag_move_all_movables = 1;
14905   flag_reduce_all_givs = 1;
14906   flag_argument_noalias = 2;
14907   flag_errno_math = 0;
14908   flag_complex_divide_method = 1;
14909 }
14910
14911 void
14912 lang_init ()
14913 {
14914   /* If the file is output from cpp, it should contain a first line
14915      `# 1 "real-filename"', and the current design of gcc (toplev.c
14916      in particular and the way it sets up information relied on by
14917      INCLUDE) requires that we read this now, and store the
14918      "real-filename" info in master_input_filename.  Ask the lexer
14919      to try doing this.  */
14920   ffelex_hash_kludge (finput);
14921 }
14922
14923 int
14924 mark_addressable (exp)
14925      tree exp;
14926 {
14927   register tree x = exp;
14928   while (1)
14929     switch (TREE_CODE (x))
14930       {
14931       case ADDR_EXPR:
14932       case COMPONENT_REF:
14933       case ARRAY_REF:
14934         x = TREE_OPERAND (x, 0);
14935         break;
14936
14937       case CONSTRUCTOR:
14938         TREE_ADDRESSABLE (x) = 1;
14939         return 1;
14940
14941       case VAR_DECL:
14942       case CONST_DECL:
14943       case PARM_DECL:
14944       case RESULT_DECL:
14945         if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)
14946             && DECL_NONLOCAL (x))
14947           {
14948             if (TREE_PUBLIC (x))
14949               {
14950                 assert ("address of global register var requested" == NULL);
14951                 return 0;
14952               }
14953             assert ("address of register variable requested" == NULL);
14954           }
14955         else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
14956           {
14957             if (TREE_PUBLIC (x))
14958               {
14959                 assert ("address of global register var requested" == NULL);
14960                 return 0;
14961               }
14962             assert ("address of register var requested" == NULL);
14963           }
14964         put_var_into_stack (x);
14965
14966         /* drops in */
14967       case FUNCTION_DECL:
14968         TREE_ADDRESSABLE (x) = 1;
14969 #if 0                           /* poplevel deals with this now.  */
14970         if (DECL_CONTEXT (x) == 0)
14971           TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1;
14972 #endif
14973
14974       default:
14975         return 1;
14976       }
14977 }
14978
14979 /* If DECL has a cleanup, build and return that cleanup here.
14980    This is a callback called by expand_expr.  */
14981
14982 tree
14983 maybe_build_cleanup (decl)
14984      tree decl UNUSED;
14985 {
14986   /* There are no cleanups in Fortran.  */
14987   return NULL_TREE;
14988 }
14989
14990 /* Exit a binding level.
14991    Pop the level off, and restore the state of the identifier-decl mappings
14992    that were in effect when this level was entered.
14993
14994    If KEEP is nonzero, this level had explicit declarations, so
14995    and create a "block" (a BLOCK node) for the level
14996    to record its declarations and subblocks for symbol table output.
14997
14998    If FUNCTIONBODY is nonzero, this level is the body of a function,
14999    so create a block as if KEEP were set and also clear out all
15000    label names.
15001
15002    If REVERSE is nonzero, reverse the order of decls before putting
15003    them into the BLOCK.  */
15004
15005 tree
15006 poplevel (keep, reverse, functionbody)
15007      int keep;
15008      int reverse;
15009      int functionbody;
15010 {
15011   register tree link;
15012   /* The chain of decls was accumulated in reverse order.
15013      Put it into forward order, just for cleanliness.  */
15014   tree decls;
15015   tree subblocks = current_binding_level->blocks;
15016   tree block = 0;
15017   tree decl;
15018   int block_previously_created;
15019
15020   /* Get the decls in the order they were written.
15021      Usually current_binding_level->names is in reverse order.
15022      But parameter decls were previously put in forward order.  */
15023
15024   if (reverse)
15025     current_binding_level->names
15026       = decls = nreverse (current_binding_level->names);
15027   else
15028     decls = current_binding_level->names;
15029
15030   /* Output any nested inline functions within this block
15031      if they weren't already output.  */
15032
15033   for (decl = decls; decl; decl = TREE_CHAIN (decl))
15034     if (TREE_CODE (decl) == FUNCTION_DECL
15035         && ! TREE_ASM_WRITTEN (decl)
15036         && DECL_INITIAL (decl) != 0
15037         && TREE_ADDRESSABLE (decl))
15038       {
15039         /* If this decl was copied from a file-scope decl
15040            on account of a block-scope extern decl,
15041            propagate TREE_ADDRESSABLE to the file-scope decl.
15042
15043            DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
15044            true, since then the decl goes through save_for_inline_copying.  */
15045         if (DECL_ABSTRACT_ORIGIN (decl) != 0
15046             && DECL_ABSTRACT_ORIGIN (decl) != decl)
15047           TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1;
15048         else if (DECL_SAVED_INSNS (decl) != 0)
15049           {
15050             push_function_context ();
15051             output_inline_function (decl);
15052             pop_function_context ();
15053           }
15054       }
15055
15056   /* If there were any declarations or structure tags in that level,
15057      or if this level is a function body,
15058      create a BLOCK to record them for the life of this function.  */
15059
15060   block = 0;
15061   block_previously_created = (current_binding_level->this_block != 0);
15062   if (block_previously_created)
15063     block = current_binding_level->this_block;
15064   else if (keep || functionbody)
15065     block = make_node (BLOCK);
15066   if (block != 0)
15067     {
15068       BLOCK_VARS (block) = decls;
15069       BLOCK_SUBBLOCKS (block) = subblocks;
15070     }
15071
15072   /* In each subblock, record that this is its superior.  */
15073
15074   for (link = subblocks; link; link = TREE_CHAIN (link))
15075     BLOCK_SUPERCONTEXT (link) = block;
15076
15077   /* Clear out the meanings of the local variables of this level.  */
15078
15079   for (link = decls; link; link = TREE_CHAIN (link))
15080     {
15081       if (DECL_NAME (link) != 0)
15082         {
15083           /* If the ident. was used or addressed via a local extern decl,
15084              don't forget that fact.  */
15085           if (DECL_EXTERNAL (link))
15086             {
15087               if (TREE_USED (link))
15088                 TREE_USED (DECL_NAME (link)) = 1;
15089               if (TREE_ADDRESSABLE (link))
15090                 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link)) = 1;
15091             }
15092           IDENTIFIER_LOCAL_VALUE (DECL_NAME (link)) = 0;
15093         }
15094     }
15095
15096   /* If the level being exited is the top level of a function,
15097      check over all the labels, and clear out the current
15098      (function local) meanings of their names.  */
15099
15100   if (functionbody)
15101     {
15102       /* If this is the top level block of a function,
15103          the vars are the function's parameters.
15104          Don't leave them in the BLOCK because they are
15105          found in the FUNCTION_DECL instead.  */
15106
15107       BLOCK_VARS (block) = 0;
15108     }
15109
15110   /* Pop the current level, and free the structure for reuse.  */
15111
15112   {
15113     register struct binding_level *level = current_binding_level;
15114     current_binding_level = current_binding_level->level_chain;
15115
15116     level->level_chain = free_binding_level;
15117     free_binding_level = level;
15118   }
15119
15120   /* Dispose of the block that we just made inside some higher level.  */
15121   if (functionbody
15122       && current_function_decl != error_mark_node)
15123     DECL_INITIAL (current_function_decl) = block;
15124   else if (block)
15125     {
15126       if (!block_previously_created)
15127         current_binding_level->blocks
15128           = chainon (current_binding_level->blocks, block);
15129     }
15130   /* If we did not make a block for the level just exited,
15131      any blocks made for inner levels
15132      (since they cannot be recorded as subblocks in that level)
15133      must be carried forward so they will later become subblocks
15134      of something else.  */
15135   else if (subblocks)
15136     current_binding_level->blocks
15137       = chainon (current_binding_level->blocks, subblocks);
15138
15139   if (block)
15140     TREE_USED (block) = 1;
15141   return block;
15142 }
15143
15144 void
15145 print_lang_decl (file, node, indent)
15146      FILE *file UNUSED;
15147      tree node UNUSED;
15148      int indent UNUSED;
15149 {
15150 }
15151
15152 void
15153 print_lang_identifier (file, node, indent)
15154      FILE *file;
15155      tree node;
15156      int indent;
15157 {
15158   print_node (file, "global", IDENTIFIER_GLOBAL_VALUE (node), indent + 4);
15159   print_node (file, "local", IDENTIFIER_LOCAL_VALUE (node), indent + 4);
15160 }
15161
15162 void
15163 print_lang_statistics ()
15164 {
15165 }
15166
15167 void
15168 print_lang_type (file, node, indent)
15169      FILE *file UNUSED;
15170      tree node UNUSED;
15171      int indent UNUSED;
15172 {
15173 }
15174
15175 /* Record a decl-node X as belonging to the current lexical scope.
15176    Check for errors (such as an incompatible declaration for the same
15177    name already seen in the same scope).
15178
15179    Returns either X or an old decl for the same name.
15180    If an old decl is returned, it may have been smashed
15181    to agree with what X says.  */
15182
15183 tree
15184 pushdecl (x)
15185      tree x;
15186 {
15187   register tree t;
15188   register tree name = DECL_NAME (x);
15189   register struct binding_level *b = current_binding_level;
15190
15191   if ((TREE_CODE (x) == FUNCTION_DECL)
15192       && (DECL_INITIAL (x) == 0)
15193       && DECL_EXTERNAL (x))
15194     DECL_CONTEXT (x) = NULL_TREE;
15195   else
15196     DECL_CONTEXT (x) = current_function_decl;
15197
15198   if (name)
15199     {
15200       if (IDENTIFIER_INVENTED (name))
15201         {
15202 #if BUILT_FOR_270
15203           DECL_ARTIFICIAL (x) = 1;
15204 #endif
15205           DECL_IN_SYSTEM_HEADER (x) = 1;
15206         }
15207
15208       t = lookup_name_current_level (name);
15209
15210       assert ((t == NULL_TREE) || (DECL_CONTEXT (x) == NULL_TREE));
15211
15212       /* Don't push non-parms onto list for parms until we understand
15213          why we're doing this and whether it works.  */
15214
15215       assert ((b == global_binding_level)
15216               || !ffecom_transform_only_dummies_
15217               || TREE_CODE (x) == PARM_DECL);
15218
15219       if ((t != NULL_TREE) && duplicate_decls (x, t))
15220         return t;
15221
15222       /* If we are processing a typedef statement, generate a whole new
15223          ..._TYPE node (which will be just an variant of the existing
15224          ..._TYPE node with identical properties) and then install the
15225          TYPE_DECL node generated to represent the typedef name as the
15226          TYPE_NAME of this brand new (duplicate) ..._TYPE node.
15227
15228          The whole point here is to end up with a situation where each and every
15229          ..._TYPE node the compiler creates will be uniquely associated with
15230          AT MOST one node representing a typedef name. This way, even though
15231          the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
15232          (i.e. "typedef name") nodes very early on, later parts of the
15233          compiler can always do the reverse translation and get back the
15234          corresponding typedef name.  For example, given:
15235
15236          typedef struct S MY_TYPE; MY_TYPE object;
15237
15238          Later parts of the compiler might only know that `object' was of type
15239          `struct S' if it were not for code just below.  With this code
15240          however, later parts of the compiler see something like:
15241
15242          struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
15243
15244          And they can then deduce (from the node for type struct S') that the
15245          original object declaration was:
15246
15247          MY_TYPE object;
15248
15249          Being able to do this is important for proper support of protoize, and
15250          also for generating precise symbolic debugging information which
15251          takes full account of the programmer's (typedef) vocabulary.
15252
15253          Obviously, we don't want to generate a duplicate ..._TYPE node if the
15254          TYPE_DECL node that we are now processing really represents a
15255          standard built-in type.
15256
15257          Since all standard types are effectively declared at line zero in the
15258          source file, we can easily check to see if we are working on a
15259          standard type by checking the current value of lineno.  */
15260
15261       if (TREE_CODE (x) == TYPE_DECL)
15262         {
15263           if (DECL_SOURCE_LINE (x) == 0)
15264             {
15265               if (TYPE_NAME (TREE_TYPE (x)) == 0)
15266                 TYPE_NAME (TREE_TYPE (x)) = x;
15267             }
15268           else if (TREE_TYPE (x) != error_mark_node)
15269             {
15270               tree tt = TREE_TYPE (x);
15271
15272               tt = build_type_copy (tt);
15273               TYPE_NAME (tt) = x;
15274               TREE_TYPE (x) = tt;
15275             }
15276         }
15277
15278       /* This name is new in its binding level. Install the new declaration
15279          and return it.  */
15280       if (b == global_binding_level)
15281         IDENTIFIER_GLOBAL_VALUE (name) = x;
15282       else
15283         IDENTIFIER_LOCAL_VALUE (name) = x;
15284     }
15285
15286   /* Put decls on list in reverse order. We will reverse them later if
15287      necessary.  */
15288   TREE_CHAIN (x) = b->names;
15289   b->names = x;
15290
15291   return x;
15292 }
15293
15294 /* Nonzero if the current level needs to have a BLOCK made.  */
15295
15296 static int
15297 kept_level_p ()
15298 {
15299   tree decl;
15300
15301   for (decl = current_binding_level->names;
15302        decl;
15303        decl = TREE_CHAIN (decl))
15304     {
15305       if (TREE_USED (decl) || TREE_CODE (decl) != VAR_DECL
15306           || (DECL_NAME (decl) && ! DECL_ARTIFICIAL (decl)))
15307         /* Currently, there aren't supposed to be non-artificial names
15308            at other than the top block for a function -- they're
15309            believed to always be temps.  But it's wise to check anyway.  */
15310         return 1;
15311     }
15312   return 0;
15313 }
15314
15315 /* Enter a new binding level.
15316    If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
15317    not for that of tags.  */
15318
15319 void
15320 pushlevel (tag_transparent)
15321      int tag_transparent;
15322 {
15323   register struct binding_level *newlevel = NULL_BINDING_LEVEL;
15324
15325   assert (! tag_transparent);
15326
15327   if (current_binding_level == global_binding_level)
15328     {
15329       named_labels = 0;
15330     }
15331
15332   /* Reuse or create a struct for this binding level.  */
15333
15334   if (free_binding_level)
15335     {
15336       newlevel = free_binding_level;
15337       free_binding_level = free_binding_level->level_chain;
15338     }
15339   else
15340     {
15341       newlevel = make_binding_level ();
15342     }
15343
15344   /* Add this level to the front of the chain (stack) of levels that
15345      are active.  */
15346
15347   *newlevel = clear_binding_level;
15348   newlevel->level_chain = current_binding_level;
15349   current_binding_level = newlevel;
15350 }
15351
15352 /* Set the BLOCK node for the innermost scope
15353    (the one we are currently in).  */
15354
15355 void
15356 set_block (block)
15357      register tree block;
15358 {
15359   current_binding_level->this_block = block;
15360 }
15361
15362 /* ~~gcc/tree.h *should* declare this, because toplev.c references it.  */
15363
15364 /* Can't 'yydebug' a front end not generated by yacc/bison!  */
15365
15366 void
15367 set_yydebug (value)
15368      int value;
15369 {
15370   if (value)
15371     fprintf (stderr, "warning: no yacc/bison-generated output to debug!\n");
15372 }
15373
15374 tree
15375 signed_or_unsigned_type (unsignedp, type)
15376      int unsignedp;
15377      tree type;
15378 {
15379   tree type2;
15380
15381   if (! INTEGRAL_TYPE_P (type))
15382     return type;
15383   if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
15384     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15385   if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
15386     return unsignedp ? unsigned_type_node : integer_type_node;
15387   if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
15388     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15389   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
15390     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15391   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
15392     return (unsignedp ? long_long_unsigned_type_node
15393             : long_long_integer_type_node);
15394
15395   type2 = type_for_size (TYPE_PRECISION (type), unsignedp);
15396   if (type2 == NULL_TREE)
15397     return type;
15398
15399   return type2;
15400 }
15401
15402 tree
15403 signed_type (type)
15404      tree type;
15405 {
15406   tree type1 = TYPE_MAIN_VARIANT (type);
15407   ffeinfoKindtype kt;
15408   tree type2;
15409
15410   if (type1 == unsigned_char_type_node || type1 == char_type_node)
15411     return signed_char_type_node;
15412   if (type1 == unsigned_type_node)
15413     return integer_type_node;
15414   if (type1 == short_unsigned_type_node)
15415     return short_integer_type_node;
15416   if (type1 == long_unsigned_type_node)
15417     return long_integer_type_node;
15418   if (type1 == long_long_unsigned_type_node)
15419     return long_long_integer_type_node;
15420 #if 0   /* gcc/c-* files only */
15421   if (type1 == unsigned_intDI_type_node)
15422     return intDI_type_node;
15423   if (type1 == unsigned_intSI_type_node)
15424     return intSI_type_node;
15425   if (type1 == unsigned_intHI_type_node)
15426     return intHI_type_node;
15427   if (type1 == unsigned_intQI_type_node)
15428     return intQI_type_node;
15429 #endif
15430
15431   type2 = type_for_size (TYPE_PRECISION (type1), 0);
15432   if (type2 != NULL_TREE)
15433     return type2;
15434
15435   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15436     {
15437       type2 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15438
15439       if (type1 == type2)
15440         return ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15441     }
15442
15443   return type;
15444 }
15445
15446 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
15447    or validate its data type for an `if' or `while' statement or ?..: exp.
15448
15449    This preparation consists of taking the ordinary
15450    representation of an expression expr and producing a valid tree
15451    boolean expression describing whether expr is nonzero.  We could
15452    simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
15453    but we optimize comparisons, &&, ||, and !.
15454
15455    The resulting type should always be `integer_type_node'.  */
15456
15457 tree
15458 truthvalue_conversion (expr)
15459      tree expr;
15460 {
15461   if (TREE_CODE (expr) == ERROR_MARK)
15462     return expr;
15463
15464 #if 0 /* This appears to be wrong for C++.  */
15465   /* These really should return error_mark_node after 2.4 is stable.
15466      But not all callers handle ERROR_MARK properly.  */
15467   switch (TREE_CODE (TREE_TYPE (expr)))
15468     {
15469     case RECORD_TYPE:
15470       error ("struct type value used where scalar is required");
15471       return integer_zero_node;
15472
15473     case UNION_TYPE:
15474       error ("union type value used where scalar is required");
15475       return integer_zero_node;
15476
15477     case ARRAY_TYPE:
15478       error ("array type value used where scalar is required");
15479       return integer_zero_node;
15480
15481     default:
15482       break;
15483     }
15484 #endif /* 0 */
15485
15486   switch (TREE_CODE (expr))
15487     {
15488       /* It is simpler and generates better code to have only TRUTH_*_EXPR
15489          or comparison expressions as truth values at this level.  */
15490 #if 0
15491     case COMPONENT_REF:
15492       /* A one-bit unsigned bit-field is already acceptable.  */
15493       if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr, 1)))
15494           && TREE_UNSIGNED (TREE_OPERAND (expr, 1)))
15495         return expr;
15496       break;
15497 #endif
15498
15499     case EQ_EXPR:
15500       /* It is simpler and generates better code to have only TRUTH_*_EXPR
15501          or comparison expressions as truth values at this level.  */
15502 #if 0
15503       if (integer_zerop (TREE_OPERAND (expr, 1)))
15504         return build_unary_op (TRUTH_NOT_EXPR, TREE_OPERAND (expr, 0), 0);
15505 #endif
15506     case NE_EXPR: case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR:
15507     case TRUTH_ANDIF_EXPR:
15508     case TRUTH_ORIF_EXPR:
15509     case TRUTH_AND_EXPR:
15510     case TRUTH_OR_EXPR:
15511     case TRUTH_XOR_EXPR:
15512       TREE_TYPE (expr) = integer_type_node;
15513       return expr;
15514
15515     case ERROR_MARK:
15516       return expr;
15517
15518     case INTEGER_CST:
15519       return integer_zerop (expr) ? integer_zero_node : integer_one_node;
15520
15521     case REAL_CST:
15522       return real_zerop (expr) ? integer_zero_node : integer_one_node;
15523
15524     case ADDR_EXPR:
15525       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 0)))
15526         return build (COMPOUND_EXPR, integer_type_node,
15527                       TREE_OPERAND (expr, 0), integer_one_node);
15528       else
15529         return integer_one_node;
15530
15531     case COMPLEX_EXPR:
15532       return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1))
15533                         ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
15534                        integer_type_node,
15535                        truthvalue_conversion (TREE_OPERAND (expr, 0)),
15536                        truthvalue_conversion (TREE_OPERAND (expr, 1)));
15537
15538     case NEGATE_EXPR:
15539     case ABS_EXPR:
15540     case FLOAT_EXPR:
15541     case FFS_EXPR:
15542       /* These don't change whether an object is non-zero or zero.  */
15543       return truthvalue_conversion (TREE_OPERAND (expr, 0));
15544
15545     case LROTATE_EXPR:
15546     case RROTATE_EXPR:
15547       /* These don't change whether an object is zero or non-zero, but
15548          we can't ignore them if their second arg has side-effects.  */
15549       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)))
15550         return build (COMPOUND_EXPR, integer_type_node, TREE_OPERAND (expr, 1),
15551                       truthvalue_conversion (TREE_OPERAND (expr, 0)));
15552       else
15553         return truthvalue_conversion (TREE_OPERAND (expr, 0));
15554
15555     case COND_EXPR:
15556       /* Distribute the conversion into the arms of a COND_EXPR.  */
15557       return fold (build (COND_EXPR, integer_type_node, TREE_OPERAND (expr, 0),
15558                           truthvalue_conversion (TREE_OPERAND (expr, 1)),
15559                           truthvalue_conversion (TREE_OPERAND (expr, 2))));
15560
15561     case CONVERT_EXPR:
15562       /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
15563          since that affects how `default_conversion' will behave.  */
15564       if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE
15565           || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE)
15566         break;
15567       /* fall through... */
15568     case NOP_EXPR:
15569       /* If this is widening the argument, we can ignore it.  */
15570       if (TYPE_PRECISION (TREE_TYPE (expr))
15571           >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0))))
15572         return truthvalue_conversion (TREE_OPERAND (expr, 0));
15573       break;
15574
15575     case MINUS_EXPR:
15576       /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
15577          this case.  */
15578       if (TARGET_FLOAT_FORMAT == IEEE_FLOAT_FORMAT
15579           && TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE)
15580         break;
15581       /* fall through... */
15582     case BIT_XOR_EXPR:
15583       /* This and MINUS_EXPR can be changed into a comparison of the
15584          two objects.  */
15585       if (TREE_TYPE (TREE_OPERAND (expr, 0))
15586           == TREE_TYPE (TREE_OPERAND (expr, 1)))
15587         return ffecom_2 (NE_EXPR, integer_type_node,
15588                          TREE_OPERAND (expr, 0),
15589                          TREE_OPERAND (expr, 1));
15590       return ffecom_2 (NE_EXPR, integer_type_node,
15591                        TREE_OPERAND (expr, 0),
15592                        fold (build1 (NOP_EXPR,
15593                                      TREE_TYPE (TREE_OPERAND (expr, 0)),
15594                                      TREE_OPERAND (expr, 1))));
15595
15596     case BIT_AND_EXPR:
15597       if (integer_onep (TREE_OPERAND (expr, 1)))
15598         return expr;
15599       break;
15600
15601     case MODIFY_EXPR:
15602 #if 0                           /* No such thing in Fortran. */
15603       if (warn_parentheses && C_EXP_ORIGINAL_CODE (expr) == MODIFY_EXPR)
15604         warning ("suggest parentheses around assignment used as truth value");
15605 #endif
15606       break;
15607
15608     default:
15609       break;
15610     }
15611
15612   if (TREE_CODE (TREE_TYPE (expr)) == COMPLEX_TYPE)
15613     return (ffecom_2
15614             ((TREE_SIDE_EFFECTS (expr)
15615               ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
15616              integer_type_node,
15617              truthvalue_conversion (ffecom_1 (REALPART_EXPR,
15618                                               TREE_TYPE (TREE_TYPE (expr)),
15619                                               expr)),
15620              truthvalue_conversion (ffecom_1 (IMAGPART_EXPR,
15621                                               TREE_TYPE (TREE_TYPE (expr)),
15622                                               expr))));
15623
15624   return ffecom_2 (NE_EXPR, integer_type_node,
15625                    expr,
15626                    convert (TREE_TYPE (expr), integer_zero_node));
15627 }
15628
15629 tree
15630 type_for_mode (mode, unsignedp)
15631      enum machine_mode mode;
15632      int unsignedp;
15633 {
15634   int i;
15635   int j;
15636   tree t;
15637
15638   if (mode == TYPE_MODE (integer_type_node))
15639     return unsignedp ? unsigned_type_node : integer_type_node;
15640
15641   if (mode == TYPE_MODE (signed_char_type_node))
15642     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15643
15644   if (mode == TYPE_MODE (short_integer_type_node))
15645     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15646
15647   if (mode == TYPE_MODE (long_integer_type_node))
15648     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15649
15650   if (mode == TYPE_MODE (long_long_integer_type_node))
15651     return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node;
15652
15653 #if HOST_BITS_PER_WIDE_INT >= 64
15654   if (mode == TYPE_MODE (intTI_type_node))
15655     return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
15656 #endif
15657
15658   if (mode == TYPE_MODE (float_type_node))
15659     return float_type_node;
15660
15661   if (mode == TYPE_MODE (double_type_node))
15662     return double_type_node;
15663
15664   if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
15665     return build_pointer_type (char_type_node);
15666
15667   if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
15668     return build_pointer_type (integer_type_node);
15669
15670   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
15671     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
15672       {
15673         if (((t = ffecom_tree_type[i][j]) != NULL_TREE)
15674             && (mode == TYPE_MODE (t)))
15675           {
15676             if ((i == FFEINFO_basictypeINTEGER) && unsignedp)
15677               return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][j];
15678             else
15679               return t;
15680           }
15681       }
15682
15683   return 0;
15684 }
15685
15686 tree
15687 type_for_size (bits, unsignedp)
15688      unsigned bits;
15689      int unsignedp;
15690 {
15691   ffeinfoKindtype kt;
15692   tree type_node;
15693
15694   if (bits == TYPE_PRECISION (integer_type_node))
15695     return unsignedp ? unsigned_type_node : integer_type_node;
15696
15697   if (bits == TYPE_PRECISION (signed_char_type_node))
15698     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15699
15700   if (bits == TYPE_PRECISION (short_integer_type_node))
15701     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15702
15703   if (bits == TYPE_PRECISION (long_integer_type_node))
15704     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15705
15706   if (bits == TYPE_PRECISION (long_long_integer_type_node))
15707     return (unsignedp ? long_long_unsigned_type_node
15708             : long_long_integer_type_node);
15709
15710   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15711     {
15712       type_node = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15713
15714       if ((type_node != NULL_TREE) && (bits == TYPE_PRECISION (type_node)))
15715         return unsignedp ? ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]
15716           : type_node;
15717     }
15718
15719   return 0;
15720 }
15721
15722 tree
15723 unsigned_type (type)
15724      tree type;
15725 {
15726   tree type1 = TYPE_MAIN_VARIANT (type);
15727   ffeinfoKindtype kt;
15728   tree type2;
15729
15730   if (type1 == signed_char_type_node || type1 == char_type_node)
15731     return unsigned_char_type_node;
15732   if (type1 == integer_type_node)
15733     return unsigned_type_node;
15734   if (type1 == short_integer_type_node)
15735     return short_unsigned_type_node;
15736   if (type1 == long_integer_type_node)
15737     return long_unsigned_type_node;
15738   if (type1 == long_long_integer_type_node)
15739     return long_long_unsigned_type_node;
15740 #if 0   /* gcc/c-* files only */
15741   if (type1 == intDI_type_node)
15742     return unsigned_intDI_type_node;
15743   if (type1 == intSI_type_node)
15744     return unsigned_intSI_type_node;
15745   if (type1 == intHI_type_node)
15746     return unsigned_intHI_type_node;
15747   if (type1 == intQI_type_node)
15748     return unsigned_intQI_type_node;
15749 #endif
15750
15751   type2 = type_for_size (TYPE_PRECISION (type1), 1);
15752   if (type2 != NULL_TREE)
15753     return type2;
15754
15755   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15756     {
15757       type2 = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15758
15759       if (type1 == type2)
15760         return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15761     }
15762
15763   return type;
15764 }
15765
15766 /* Callback routines for garbage collection.  */
15767
15768 int ggc_p = 1;
15769
15770 void
15771 lang_mark_tree (t)
15772      union tree_node *t ATTRIBUTE_UNUSED;
15773 {
15774   if (TREE_CODE (t) == IDENTIFIER_NODE)
15775     {
15776       struct lang_identifier *i = (struct lang_identifier *) t;
15777       ggc_mark_tree (IDENTIFIER_GLOBAL_VALUE (i));
15778       ggc_mark_tree (IDENTIFIER_LOCAL_VALUE (i));
15779       ggc_mark_tree (IDENTIFIER_LABEL_VALUE (i));
15780     }
15781   else if (TYPE_P (t) && TYPE_LANG_SPECIFIC (t))
15782     ggc_mark (TYPE_LANG_SPECIFIC (t));
15783 }
15784
15785 void
15786 lang_mark_false_label_stack (l)
15787      struct label_node *l;
15788 {
15789   /* Fortran doesn't use false_label_stack.  It better be NULL.  */
15790   if (l != NULL)
15791     abort();
15792 }
15793
15794 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
15795 \f
15796 #if FFECOM_GCC_INCLUDE
15797
15798 /* From gcc/cccp.c, the code to handle -I.  */
15799
15800 /* Skip leading "./" from a directory name.
15801    This may yield the empty string, which represents the current directory.  */
15802
15803 static const char *
15804 skip_redundant_dir_prefix (const char *dir)
15805 {
15806   while (dir[0] == '.' && dir[1] == '/')
15807     for (dir += 2; *dir == '/'; dir++)
15808       continue;
15809   if (dir[0] == '.' && !dir[1])
15810     dir++;
15811   return dir;
15812 }
15813
15814 /* The file_name_map structure holds a mapping of file names for a
15815    particular directory.  This mapping is read from the file named
15816    FILE_NAME_MAP_FILE in that directory.  Such a file can be used to
15817    map filenames on a file system with severe filename restrictions,
15818    such as DOS.  The format of the file name map file is just a series
15819    of lines with two tokens on each line.  The first token is the name
15820    to map, and the second token is the actual name to use.  */
15821
15822 struct file_name_map
15823 {
15824   struct file_name_map *map_next;
15825   char *map_from;
15826   char *map_to;
15827 };
15828
15829 #define FILE_NAME_MAP_FILE "header.gcc"
15830
15831 /* Current maximum length of directory names in the search path
15832    for include files.  (Altered as we get more of them.)  */
15833
15834 static int max_include_len = 0;
15835
15836 struct file_name_list
15837   {
15838     struct file_name_list *next;
15839     char *fname;
15840     /* Mapping of file names for this directory.  */
15841     struct file_name_map *name_map;
15842     /* Non-zero if name_map is valid.  */
15843     int got_name_map;
15844   };
15845
15846 static struct file_name_list *include = NULL;   /* First dir to search */
15847 static struct file_name_list *last_include = NULL;      /* Last in chain */
15848
15849 /* I/O buffer structure.
15850    The `fname' field is nonzero for source files and #include files
15851    and for the dummy text used for -D and -U.
15852    It is zero for rescanning results of macro expansion
15853    and for expanding macro arguments.  */
15854 #define INPUT_STACK_MAX 400
15855 static struct file_buf {
15856   const char *fname;
15857   /* Filename specified with #line command.  */
15858   const char *nominal_fname;
15859   /* Record where in the search path this file was found.
15860      For #include_next.  */
15861   struct file_name_list *dir;
15862   ffewhereLine line;
15863   ffewhereColumn column;
15864 } instack[INPUT_STACK_MAX];
15865
15866 static int last_error_tick = 0;    /* Incremented each time we print it.  */
15867 static int input_file_stack_tick = 0;  /* Incremented when status changes.  */
15868
15869 /* Current nesting level of input sources.
15870    `instack[indepth]' is the level currently being read.  */
15871 static int indepth = -1;
15872
15873 typedef struct file_buf FILE_BUF;
15874
15875 typedef unsigned char U_CHAR;
15876
15877 /* table to tell if char can be part of a C identifier. */
15878 U_CHAR is_idchar[256];
15879 /* table to tell if char can be first char of a c identifier. */
15880 U_CHAR is_idstart[256];
15881 /* table to tell if c is horizontal space.  */
15882 U_CHAR is_hor_space[256];
15883 /* table to tell if c is horizontal or vertical space.  */
15884 static U_CHAR is_space[256];
15885
15886 #define SKIP_WHITE_SPACE(p) do { while (is_hor_space[*p]) p++; } while (0)
15887 #define SKIP_ALL_WHITE_SPACE(p) do { while (is_space[*p]) p++; } while (0)
15888
15889 /* Nonzero means -I- has been seen,
15890    so don't look for #include "foo" the source-file directory.  */
15891 static int ignore_srcdir;
15892
15893 #ifndef INCLUDE_LEN_FUDGE
15894 #define INCLUDE_LEN_FUDGE 0
15895 #endif
15896
15897 static void append_include_chain (struct file_name_list *first,
15898                                   struct file_name_list *last);
15899 static FILE *open_include_file (char *filename,
15900                                 struct file_name_list *searchptr);
15901 static void print_containing_files (ffebadSeverity sev);
15902 static const char *skip_redundant_dir_prefix (const char *);
15903 static char *read_filename_string (int ch, FILE *f);
15904 static struct file_name_map *read_name_map (const char *dirname);
15905
15906 /* Append a chain of `struct file_name_list's
15907    to the end of the main include chain.
15908    FIRST is the beginning of the chain to append, and LAST is the end.  */
15909
15910 static void
15911 append_include_chain (first, last)
15912      struct file_name_list *first, *last;
15913 {
15914   struct file_name_list *dir;
15915
15916   if (!first || !last)
15917     return;
15918
15919   if (include == 0)
15920     include = first;
15921   else
15922     last_include->next = first;
15923
15924   for (dir = first; ; dir = dir->next) {
15925     int len = strlen (dir->fname) + INCLUDE_LEN_FUDGE;
15926     if (len > max_include_len)
15927       max_include_len = len;
15928     if (dir == last)
15929       break;
15930   }
15931
15932   last->next = NULL;
15933   last_include = last;
15934 }
15935
15936 /* Try to open include file FILENAME.  SEARCHPTR is the directory
15937    being tried from the include file search path.  This function maps
15938    filenames on file systems based on information read by
15939    read_name_map.  */
15940
15941 static FILE *
15942 open_include_file (filename, searchptr)
15943      char *filename;
15944      struct file_name_list *searchptr;
15945 {
15946   register struct file_name_map *map;
15947   register char *from;
15948   char *p, *dir;
15949
15950   if (searchptr && ! searchptr->got_name_map)
15951     {
15952       searchptr->name_map = read_name_map (searchptr->fname
15953                                            ? searchptr->fname : ".");
15954       searchptr->got_name_map = 1;
15955     }
15956
15957   /* First check the mapping for the directory we are using.  */
15958   if (searchptr && searchptr->name_map)
15959     {
15960       from = filename;
15961       if (searchptr->fname)
15962         from += strlen (searchptr->fname) + 1;
15963       for (map = searchptr->name_map; map; map = map->map_next)
15964         {
15965           if (! strcmp (map->map_from, from))
15966             {
15967               /* Found a match.  */
15968               return fopen (map->map_to, "r");
15969             }
15970         }
15971     }
15972
15973   /* Try to find a mapping file for the particular directory we are
15974      looking in.  Thus #include <sys/types.h> will look up sys/types.h
15975      in /usr/include/header.gcc and look up types.h in
15976      /usr/include/sys/header.gcc.  */
15977   p = rindex (filename, '/');
15978 #ifdef DIR_SEPARATOR
15979   if (! p) p = rindex (filename, DIR_SEPARATOR);
15980   else {
15981     char *tmp = rindex (filename, DIR_SEPARATOR);
15982     if (tmp != NULL && tmp > p) p = tmp;
15983   }
15984 #endif
15985   if (! p)
15986     p = filename;
15987   if (searchptr
15988       && searchptr->fname
15989       && strlen (searchptr->fname) == (size_t) (p - filename)
15990       && ! strncmp (searchptr->fname, filename, (int) (p - filename)))
15991     {
15992       /* FILENAME is in SEARCHPTR, which we've already checked.  */
15993       return fopen (filename, "r");
15994     }
15995
15996   if (p == filename)
15997     {
15998       from = filename;
15999       map = read_name_map (".");
16000     }
16001   else
16002     {
16003       dir = (char *) xmalloc (p - filename + 1);
16004       memcpy (dir, filename, p - filename);
16005       dir[p - filename] = '\0';
16006       from = p + 1;
16007       map = read_name_map (dir);
16008       free (dir);
16009     }
16010   for (; map; map = map->map_next)
16011     if (! strcmp (map->map_from, from))
16012       return fopen (map->map_to, "r");
16013
16014   return fopen (filename, "r");
16015 }
16016
16017 /* Print the file names and line numbers of the #include
16018    commands which led to the current file.  */
16019
16020 static void
16021 print_containing_files (ffebadSeverity sev)
16022 {
16023   FILE_BUF *ip = NULL;
16024   int i;
16025   int first = 1;
16026   const char *str1;
16027   const char *str2;
16028
16029   /* If stack of files hasn't changed since we last printed
16030      this info, don't repeat it.  */
16031   if (last_error_tick == input_file_stack_tick)
16032     return;
16033
16034   for (i = indepth; i >= 0; i--)
16035     if (instack[i].fname != NULL) {
16036       ip = &instack[i];
16037       break;
16038     }
16039
16040   /* Give up if we don't find a source file.  */
16041   if (ip == NULL)
16042     return;
16043
16044   /* Find the other, outer source files.  */
16045   for (i--; i >= 0; i--)
16046     if (instack[i].fname != NULL)
16047       {
16048         ip = &instack[i];
16049         if (first)
16050           {
16051             first = 0;
16052             str1 = "In file included";
16053           }
16054         else
16055           {
16056             str1 = "...          ...";
16057           }
16058
16059         if (i == 1)
16060           str2 = ":";
16061         else
16062           str2 = "";
16063
16064         ffebad_start_msg ("%A from %B at %0%C", sev);
16065         ffebad_here (0, ip->line, ip->column);
16066         ffebad_string (str1);
16067         ffebad_string (ip->nominal_fname);
16068         ffebad_string (str2);
16069         ffebad_finish ();
16070       }
16071
16072   /* Record we have printed the status as of this time.  */
16073   last_error_tick = input_file_stack_tick;
16074 }
16075
16076 /* Read a space delimited string of unlimited length from a stdio
16077    file.  */
16078
16079 static char *
16080 read_filename_string (ch, f)
16081      int ch;
16082      FILE *f;
16083 {
16084   char *alloc, *set;
16085   int len;
16086
16087   len = 20;
16088   set = alloc = xmalloc (len + 1);
16089   if (! is_space[ch])
16090     {
16091       *set++ = ch;
16092       while ((ch = getc (f)) != EOF && ! is_space[ch])
16093         {
16094           if (set - alloc == len)
16095             {
16096               len *= 2;
16097               alloc = xrealloc (alloc, len + 1);
16098               set = alloc + len / 2;
16099             }
16100           *set++ = ch;
16101         }
16102     }
16103   *set = '\0';
16104   ungetc (ch, f);
16105   return alloc;
16106 }
16107
16108 /* Read the file name map file for DIRNAME.  */
16109
16110 static struct file_name_map *
16111 read_name_map (dirname)
16112      const char *dirname;
16113 {
16114   /* This structure holds a linked list of file name maps, one per
16115      directory.  */
16116   struct file_name_map_list
16117     {
16118       struct file_name_map_list *map_list_next;
16119       char *map_list_name;
16120       struct file_name_map *map_list_map;
16121     };
16122   static struct file_name_map_list *map_list;
16123   register struct file_name_map_list *map_list_ptr;
16124   char *name;
16125   FILE *f;
16126   size_t dirlen;
16127   int separator_needed;
16128
16129   dirname = skip_redundant_dir_prefix (dirname);
16130
16131   for (map_list_ptr = map_list; map_list_ptr;
16132        map_list_ptr = map_list_ptr->map_list_next)
16133     if (! strcmp (map_list_ptr->map_list_name, dirname))
16134       return map_list_ptr->map_list_map;
16135
16136   map_list_ptr = ((struct file_name_map_list *)
16137                   xmalloc (sizeof (struct file_name_map_list)));
16138   map_list_ptr->map_list_name = xstrdup (dirname);
16139   map_list_ptr->map_list_map = NULL;
16140
16141   dirlen = strlen (dirname);
16142   separator_needed = dirlen != 0 && dirname[dirlen - 1] != '/';
16143   name = (char *) xmalloc (dirlen + strlen (FILE_NAME_MAP_FILE) + 2);
16144   strcpy (name, dirname);
16145   name[dirlen] = '/';
16146   strcpy (name + dirlen + separator_needed, FILE_NAME_MAP_FILE);
16147   f = fopen (name, "r");
16148   free (name);
16149   if (!f)
16150     map_list_ptr->map_list_map = NULL;
16151   else
16152     {
16153       int ch;
16154
16155       while ((ch = getc (f)) != EOF)
16156         {
16157           char *from, *to;
16158           struct file_name_map *ptr;
16159
16160           if (is_space[ch])
16161             continue;
16162           from = read_filename_string (ch, f);
16163           while ((ch = getc (f)) != EOF && is_hor_space[ch])
16164             ;
16165           to = read_filename_string (ch, f);
16166
16167           ptr = ((struct file_name_map *)
16168                  xmalloc (sizeof (struct file_name_map)));
16169           ptr->map_from = from;
16170
16171           /* Make the real filename absolute.  */
16172           if (*to == '/')
16173             ptr->map_to = to;
16174           else
16175             {
16176               ptr->map_to = xmalloc (dirlen + strlen (to) + 2);
16177               strcpy (ptr->map_to, dirname);
16178               ptr->map_to[dirlen] = '/';
16179               strcpy (ptr->map_to + dirlen + separator_needed, to);
16180               free (to);
16181             }
16182
16183           ptr->map_next = map_list_ptr->map_list_map;
16184           map_list_ptr->map_list_map = ptr;
16185
16186           while ((ch = getc (f)) != '\n')
16187             if (ch == EOF)
16188               break;
16189         }
16190       fclose (f);
16191     }
16192
16193   map_list_ptr->map_list_next = map_list;
16194   map_list = map_list_ptr;
16195
16196   return map_list_ptr->map_list_map;
16197 }
16198
16199 static void
16200 ffecom_file_ (const char *name)
16201 {
16202   FILE_BUF *fp;
16203
16204   /* Do partial setup of input buffer for the sake of generating
16205      early #line directives (when -g is in effect).  */
16206
16207   fp = &instack[++indepth];
16208   memset ((char *) fp, 0, sizeof (FILE_BUF));
16209   if (name == NULL)
16210     name = "";
16211   fp->nominal_fname = fp->fname = name;
16212 }
16213
16214 /* Initialize syntactic classifications of characters.  */
16215
16216 static void
16217 ffecom_initialize_char_syntax_ ()
16218 {
16219   register int i;
16220
16221   /*
16222    * Set up is_idchar and is_idstart tables.  These should be
16223    * faster than saying (is_alpha (c) || c == '_'), etc.
16224    * Set up these things before calling any routines tthat
16225    * refer to them.
16226    */
16227   for (i = 'a'; i <= 'z'; i++) {
16228     is_idchar[i - 'a' + 'A'] = 1;
16229     is_idchar[i] = 1;
16230     is_idstart[i - 'a' + 'A'] = 1;
16231     is_idstart[i] = 1;
16232   }
16233   for (i = '0'; i <= '9'; i++)
16234     is_idchar[i] = 1;
16235   is_idchar['_'] = 1;
16236   is_idstart['_'] = 1;
16237
16238   /* horizontal space table */
16239   is_hor_space[' '] = 1;
16240   is_hor_space['\t'] = 1;
16241   is_hor_space['\v'] = 1;
16242   is_hor_space['\f'] = 1;
16243   is_hor_space['\r'] = 1;
16244
16245   is_space[' '] = 1;
16246   is_space['\t'] = 1;
16247   is_space['\v'] = 1;
16248   is_space['\f'] = 1;
16249   is_space['\n'] = 1;
16250   is_space['\r'] = 1;
16251 }
16252
16253 static void
16254 ffecom_close_include_ (FILE *f)
16255 {
16256   fclose (f);
16257
16258   indepth--;
16259   input_file_stack_tick++;
16260
16261   ffewhere_line_kill (instack[indepth].line);
16262   ffewhere_column_kill (instack[indepth].column);
16263 }
16264
16265 static int
16266 ffecom_decode_include_option_ (char *spec)
16267 {
16268   struct file_name_list *dirtmp;
16269
16270   if (! ignore_srcdir && !strcmp (spec, "-"))
16271     ignore_srcdir = 1;
16272   else
16273     {
16274       dirtmp = (struct file_name_list *)
16275         xmalloc (sizeof (struct file_name_list));
16276       dirtmp->next = 0;         /* New one goes on the end */
16277       if (spec[0] != 0)
16278         dirtmp->fname = spec;
16279       else
16280         fatal ("Directory name must immediately follow -I option with no intervening spaces, as in `-Idir', not `-I dir'");
16281       dirtmp->got_name_map = 0;
16282       append_include_chain (dirtmp, dirtmp);
16283     }
16284   return 1;
16285 }
16286
16287 /* Open INCLUDEd file.  */
16288
16289 static FILE *
16290 ffecom_open_include_ (char *name, ffewhereLine l, ffewhereColumn c)
16291 {
16292   char *fbeg = name;
16293   size_t flen = strlen (fbeg);
16294   struct file_name_list *search_start = include; /* Chain of dirs to search */
16295   struct file_name_list dsp[1]; /* First in chain, if #include "..." */
16296   struct file_name_list *searchptr = 0;
16297   char *fname;          /* Dynamically allocated fname buffer */
16298   FILE *f;
16299   FILE_BUF *fp;
16300
16301   if (flen == 0)
16302     return NULL;
16303
16304   dsp[0].fname = NULL;
16305
16306   /* If -I- was specified, don't search current dir, only spec'd ones. */
16307   if (!ignore_srcdir)
16308     {
16309       for (fp = &instack[indepth]; fp >= instack; fp--)
16310         {
16311           int n;
16312           char *ep;
16313           const char *nam;
16314
16315           if ((nam = fp->nominal_fname) != NULL)
16316             {
16317               /* Found a named file.  Figure out dir of the file,
16318                  and put it in front of the search list.  */
16319               dsp[0].next = search_start;
16320               search_start = dsp;
16321 #ifndef VMS
16322               ep = rindex (nam, '/');
16323 #ifdef DIR_SEPARATOR
16324             if (ep == NULL) ep = rindex (nam, DIR_SEPARATOR);
16325             else {
16326               char *tmp = rindex (nam, DIR_SEPARATOR);
16327               if (tmp != NULL && tmp > ep) ep = tmp;
16328             }
16329 #endif
16330 #else                           /* VMS */
16331               ep = rindex (nam, ']');
16332               if (ep == NULL) ep = rindex (nam, '>');
16333               if (ep == NULL) ep = rindex (nam, ':');
16334               if (ep != NULL) ep++;
16335 #endif                          /* VMS */
16336               if (ep != NULL)
16337                 {
16338                   n = ep - nam;
16339                   dsp[0].fname = (char *) xmalloc (n + 1);
16340                   strncpy (dsp[0].fname, nam, n);
16341                   dsp[0].fname[n] = '\0';
16342                   if (n + INCLUDE_LEN_FUDGE > max_include_len)
16343                     max_include_len = n + INCLUDE_LEN_FUDGE;
16344                 }
16345               else
16346                 dsp[0].fname = NULL; /* Current directory */
16347               dsp[0].got_name_map = 0;
16348               break;
16349             }
16350         }
16351     }
16352
16353   /* Allocate this permanently, because it gets stored in the definitions
16354      of macros.  */
16355   fname = xmalloc (max_include_len + flen + 4);
16356   /* + 2 above for slash and terminating null.  */
16357   /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
16358      for g77 yet).  */
16359
16360   /* If specified file name is absolute, just open it.  */
16361
16362   if (*fbeg == '/'
16363 #ifdef DIR_SEPARATOR
16364       || *fbeg == DIR_SEPARATOR
16365 #endif
16366       )
16367     {
16368       strncpy (fname, (char *) fbeg, flen);
16369       fname[flen] = 0;
16370       f = open_include_file (fname, NULL_PTR);
16371     }
16372   else
16373     {
16374       f = NULL;
16375
16376       /* Search directory path, trying to open the file.
16377          Copy each filename tried into FNAME.  */
16378
16379       for (searchptr = search_start; searchptr; searchptr = searchptr->next)
16380         {
16381           if (searchptr->fname)
16382             {
16383               /* The empty string in a search path is ignored.
16384                  This makes it possible to turn off entirely
16385                  a standard piece of the list.  */
16386               if (searchptr->fname[0] == 0)
16387                 continue;
16388               strcpy (fname, skip_redundant_dir_prefix (searchptr->fname));
16389               if (fname[0] && fname[strlen (fname) - 1] != '/')
16390                 strcat (fname, "/");
16391               fname[strlen (fname) + flen] = 0;
16392             }
16393           else
16394             fname[0] = 0;
16395
16396           strncat (fname, fbeg, flen);
16397 #ifdef VMS
16398           /* Change this 1/2 Unix 1/2 VMS file specification into a
16399              full VMS file specification */
16400           if (searchptr->fname && (searchptr->fname[0] != 0))
16401             {
16402               /* Fix up the filename */
16403               hack_vms_include_specification (fname);
16404             }
16405           else
16406             {
16407               /* This is a normal VMS filespec, so use it unchanged.  */
16408               strncpy (fname, (char *) fbeg, flen);
16409               fname[flen] = 0;
16410 #if 0   /* Not for g77.  */
16411               /* if it's '#include filename', add the missing .h */
16412               if (index (fname, '.') == NULL)
16413                 strcat (fname, ".h");
16414 #endif
16415             }
16416 #endif /* VMS */
16417           f = open_include_file (fname, searchptr);
16418 #ifdef EACCES
16419           if (f == NULL && errno == EACCES)
16420             {
16421               print_containing_files (FFEBAD_severityWARNING);
16422               ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
16423                                 FFEBAD_severityWARNING);
16424               ffebad_string (fname);
16425               ffebad_here (0, l, c);
16426               ffebad_finish ();
16427             }
16428 #endif
16429           if (f != NULL)
16430             break;
16431         }
16432     }
16433
16434   if (f == NULL)
16435     {
16436       /* A file that was not found.  */
16437
16438       strncpy (fname, (char *) fbeg, flen);
16439       fname[flen] = 0;
16440       print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE));
16441       ffebad_start (FFEBAD_OPEN_INCLUDE);
16442       ffebad_here (0, l, c);
16443       ffebad_string (fname);
16444       ffebad_finish ();
16445     }
16446
16447   if (dsp[0].fname != NULL)
16448     free (dsp[0].fname);
16449
16450   if (f == NULL)
16451     return NULL;
16452
16453   if (indepth >= (INPUT_STACK_MAX - 1))
16454     {
16455       print_containing_files (FFEBAD_severityFATAL);
16456       ffebad_start_msg ("At %0, INCLUDE nesting too deep",
16457                         FFEBAD_severityFATAL);
16458       ffebad_string (fname);
16459       ffebad_here (0, l, c);
16460       ffebad_finish ();
16461       return NULL;
16462     }
16463
16464   instack[indepth].line = ffewhere_line_use (l);
16465   instack[indepth].column = ffewhere_column_use (c);
16466
16467   fp = &instack[indepth + 1];
16468   memset ((char *) fp, 0, sizeof (FILE_BUF));
16469   fp->nominal_fname = fp->fname = fname;
16470   fp->dir = searchptr;
16471
16472   indepth++;
16473   input_file_stack_tick++;
16474
16475   return f;
16476 }
16477 #endif  /* FFECOM_GCC_INCLUDE */
16478
16479 /**INDENT* (Do not reformat this comment even with -fca option.)
16480    Data-gathering files: Given the source file listed below, compiled with
16481    f2c I obtained the output file listed after that, and from the output
16482    file I derived the above code.
16483
16484 -------- (begin input file to f2c)
16485         implicit none
16486         character*10 A1,A2
16487         complex C1,C2
16488         integer I1,I2
16489         real R1,R2
16490         double precision D1,D2
16491 C
16492         call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
16493 c /
16494         call fooI(I1/I2)
16495         call fooR(R1/I1)
16496         call fooD(D1/I1)
16497         call fooC(C1/I1)
16498         call fooR(R1/R2)
16499         call fooD(R1/D1)
16500         call fooD(D1/D2)
16501         call fooD(D1/R1)
16502         call fooC(C1/C2)
16503         call fooC(C1/R1)
16504         call fooZ(C1/D1)
16505 c **
16506         call fooI(I1**I2)
16507         call fooR(R1**I1)
16508         call fooD(D1**I1)
16509         call fooC(C1**I1)
16510         call fooR(R1**R2)
16511         call fooD(R1**D1)
16512         call fooD(D1**D2)
16513         call fooD(D1**R1)
16514         call fooC(C1**C2)
16515         call fooC(C1**R1)
16516         call fooZ(C1**D1)
16517 c FFEINTRIN_impABS
16518         call fooR(ABS(R1))
16519 c FFEINTRIN_impACOS
16520         call fooR(ACOS(R1))
16521 c FFEINTRIN_impAIMAG
16522         call fooR(AIMAG(C1))
16523 c FFEINTRIN_impAINT
16524         call fooR(AINT(R1))
16525 c FFEINTRIN_impALOG
16526         call fooR(ALOG(R1))
16527 c FFEINTRIN_impALOG10
16528         call fooR(ALOG10(R1))
16529 c FFEINTRIN_impAMAX0
16530         call fooR(AMAX0(I1,I2))
16531 c FFEINTRIN_impAMAX1
16532         call fooR(AMAX1(R1,R2))
16533 c FFEINTRIN_impAMIN0
16534         call fooR(AMIN0(I1,I2))
16535 c FFEINTRIN_impAMIN1
16536         call fooR(AMIN1(R1,R2))
16537 c FFEINTRIN_impAMOD
16538         call fooR(AMOD(R1,R2))
16539 c FFEINTRIN_impANINT
16540         call fooR(ANINT(R1))
16541 c FFEINTRIN_impASIN
16542         call fooR(ASIN(R1))
16543 c FFEINTRIN_impATAN
16544         call fooR(ATAN(R1))
16545 c FFEINTRIN_impATAN2
16546         call fooR(ATAN2(R1,R2))
16547 c FFEINTRIN_impCABS
16548         call fooR(CABS(C1))
16549 c FFEINTRIN_impCCOS
16550         call fooC(CCOS(C1))
16551 c FFEINTRIN_impCEXP
16552         call fooC(CEXP(C1))
16553 c FFEINTRIN_impCHAR
16554         call fooA(CHAR(I1))
16555 c FFEINTRIN_impCLOG
16556         call fooC(CLOG(C1))
16557 c FFEINTRIN_impCONJG
16558         call fooC(CONJG(C1))
16559 c FFEINTRIN_impCOS
16560         call fooR(COS(R1))
16561 c FFEINTRIN_impCOSH
16562         call fooR(COSH(R1))
16563 c FFEINTRIN_impCSIN
16564         call fooC(CSIN(C1))
16565 c FFEINTRIN_impCSQRT
16566         call fooC(CSQRT(C1))
16567 c FFEINTRIN_impDABS
16568         call fooD(DABS(D1))
16569 c FFEINTRIN_impDACOS
16570         call fooD(DACOS(D1))
16571 c FFEINTRIN_impDASIN
16572         call fooD(DASIN(D1))
16573 c FFEINTRIN_impDATAN
16574         call fooD(DATAN(D1))
16575 c FFEINTRIN_impDATAN2
16576         call fooD(DATAN2(D1,D2))
16577 c FFEINTRIN_impDCOS
16578         call fooD(DCOS(D1))
16579 c FFEINTRIN_impDCOSH
16580         call fooD(DCOSH(D1))
16581 c FFEINTRIN_impDDIM
16582         call fooD(DDIM(D1,D2))
16583 c FFEINTRIN_impDEXP
16584         call fooD(DEXP(D1))
16585 c FFEINTRIN_impDIM
16586         call fooR(DIM(R1,R2))
16587 c FFEINTRIN_impDINT
16588         call fooD(DINT(D1))
16589 c FFEINTRIN_impDLOG
16590         call fooD(DLOG(D1))
16591 c FFEINTRIN_impDLOG10
16592         call fooD(DLOG10(D1))
16593 c FFEINTRIN_impDMAX1
16594         call fooD(DMAX1(D1,D2))
16595 c FFEINTRIN_impDMIN1
16596         call fooD(DMIN1(D1,D2))
16597 c FFEINTRIN_impDMOD
16598         call fooD(DMOD(D1,D2))
16599 c FFEINTRIN_impDNINT
16600         call fooD(DNINT(D1))
16601 c FFEINTRIN_impDPROD
16602         call fooD(DPROD(R1,R2))
16603 c FFEINTRIN_impDSIGN
16604         call fooD(DSIGN(D1,D2))
16605 c FFEINTRIN_impDSIN
16606         call fooD(DSIN(D1))
16607 c FFEINTRIN_impDSINH
16608         call fooD(DSINH(D1))
16609 c FFEINTRIN_impDSQRT
16610         call fooD(DSQRT(D1))
16611 c FFEINTRIN_impDTAN
16612         call fooD(DTAN(D1))
16613 c FFEINTRIN_impDTANH
16614         call fooD(DTANH(D1))
16615 c FFEINTRIN_impEXP
16616         call fooR(EXP(R1))
16617 c FFEINTRIN_impIABS
16618         call fooI(IABS(I1))
16619 c FFEINTRIN_impICHAR
16620         call fooI(ICHAR(A1))
16621 c FFEINTRIN_impIDIM
16622         call fooI(IDIM(I1,I2))
16623 c FFEINTRIN_impIDNINT
16624         call fooI(IDNINT(D1))
16625 c FFEINTRIN_impINDEX
16626         call fooI(INDEX(A1,A2))
16627 c FFEINTRIN_impISIGN
16628         call fooI(ISIGN(I1,I2))
16629 c FFEINTRIN_impLEN
16630         call fooI(LEN(A1))
16631 c FFEINTRIN_impLGE
16632         call fooL(LGE(A1,A2))
16633 c FFEINTRIN_impLGT
16634         call fooL(LGT(A1,A2))
16635 c FFEINTRIN_impLLE
16636         call fooL(LLE(A1,A2))
16637 c FFEINTRIN_impLLT
16638         call fooL(LLT(A1,A2))
16639 c FFEINTRIN_impMAX0
16640         call fooI(MAX0(I1,I2))
16641 c FFEINTRIN_impMAX1
16642         call fooI(MAX1(R1,R2))
16643 c FFEINTRIN_impMIN0
16644         call fooI(MIN0(I1,I2))
16645 c FFEINTRIN_impMIN1
16646         call fooI(MIN1(R1,R2))
16647 c FFEINTRIN_impMOD
16648         call fooI(MOD(I1,I2))
16649 c FFEINTRIN_impNINT
16650         call fooI(NINT(R1))
16651 c FFEINTRIN_impSIGN
16652         call fooR(SIGN(R1,R2))
16653 c FFEINTRIN_impSIN
16654         call fooR(SIN(R1))
16655 c FFEINTRIN_impSINH
16656         call fooR(SINH(R1))
16657 c FFEINTRIN_impSQRT
16658         call fooR(SQRT(R1))
16659 c FFEINTRIN_impTAN
16660         call fooR(TAN(R1))
16661 c FFEINTRIN_impTANH
16662         call fooR(TANH(R1))
16663 c FFEINTRIN_imp_CMPLX_C
16664         call fooC(cmplx(C1,C2))
16665 c FFEINTRIN_imp_CMPLX_D
16666         call fooZ(cmplx(D1,D2))
16667 c FFEINTRIN_imp_CMPLX_I
16668         call fooC(cmplx(I1,I2))
16669 c FFEINTRIN_imp_CMPLX_R
16670         call fooC(cmplx(R1,R2))
16671 c FFEINTRIN_imp_DBLE_C
16672         call fooD(dble(C1))
16673 c FFEINTRIN_imp_DBLE_D
16674         call fooD(dble(D1))
16675 c FFEINTRIN_imp_DBLE_I
16676         call fooD(dble(I1))
16677 c FFEINTRIN_imp_DBLE_R
16678         call fooD(dble(R1))
16679 c FFEINTRIN_imp_INT_C
16680         call fooI(int(C1))
16681 c FFEINTRIN_imp_INT_D
16682         call fooI(int(D1))
16683 c FFEINTRIN_imp_INT_I
16684         call fooI(int(I1))
16685 c FFEINTRIN_imp_INT_R
16686         call fooI(int(R1))
16687 c FFEINTRIN_imp_REAL_C
16688         call fooR(real(C1))
16689 c FFEINTRIN_imp_REAL_D
16690         call fooR(real(D1))
16691 c FFEINTRIN_imp_REAL_I
16692         call fooR(real(I1))
16693 c FFEINTRIN_imp_REAL_R
16694         call fooR(real(R1))
16695 c
16696 c FFEINTRIN_imp_INT_D:
16697 c
16698 c FFEINTRIN_specIDINT
16699         call fooI(IDINT(D1))
16700 c
16701 c FFEINTRIN_imp_INT_R:
16702 c
16703 c FFEINTRIN_specIFIX
16704         call fooI(IFIX(R1))
16705 c FFEINTRIN_specINT
16706         call fooI(INT(R1))
16707 c
16708 c FFEINTRIN_imp_REAL_D:
16709 c
16710 c FFEINTRIN_specSNGL
16711         call fooR(SNGL(D1))
16712 c
16713 c FFEINTRIN_imp_REAL_I:
16714 c
16715 c FFEINTRIN_specFLOAT
16716         call fooR(FLOAT(I1))
16717 c FFEINTRIN_specREAL
16718         call fooR(REAL(I1))
16719 c
16720         end
16721 -------- (end input file to f2c)
16722
16723 -------- (begin output from providing above input file as input to:
16724 --------  `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
16725 --------     -e "s:^#.*$::g"')
16726
16727 //  -- translated by f2c (version 19950223).
16728    You must link the resulting object file with the libraries:
16729         -lf2c -lm   (in that order)
16730 //
16731
16732
16733 // f2c.h  --  Standard Fortran to C header file //
16734
16735 ///  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
16736
16737         - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
16738
16739
16740
16741
16742 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
16743 // we assume short, float are OK //
16744 typedef long int // long int // integer;
16745 typedef char *address;
16746 typedef short int shortint;
16747 typedef float real;
16748 typedef double doublereal;
16749 typedef struct { real r, i; } complex;
16750 typedef struct { doublereal r, i; } doublecomplex;
16751 typedef long int // long int // logical;
16752 typedef short int shortlogical;
16753 typedef char logical1;
16754 typedef char integer1;
16755 // typedef long long longint; // // system-dependent //
16756
16757
16758
16759
16760 // Extern is for use with -E //
16761
16762
16763
16764
16765 // I/O stuff //
16766
16767
16768
16769
16770
16771
16772
16773
16774 typedef long int // int or long int // flag;
16775 typedef long int // int or long int // ftnlen;
16776 typedef long int // int or long int // ftnint;
16777
16778
16779 //external read, write//
16780 typedef struct
16781 {       flag cierr;
16782         ftnint ciunit;
16783         flag ciend;
16784         char *cifmt;
16785         ftnint cirec;
16786 } cilist;
16787
16788 //internal read, write//
16789 typedef struct
16790 {       flag icierr;
16791         char *iciunit;
16792         flag iciend;
16793         char *icifmt;
16794         ftnint icirlen;
16795         ftnint icirnum;
16796 } icilist;
16797
16798 //open//
16799 typedef struct
16800 {       flag oerr;
16801         ftnint ounit;
16802         char *ofnm;
16803         ftnlen ofnmlen;
16804         char *osta;
16805         char *oacc;
16806         char *ofm;
16807         ftnint orl;
16808         char *oblnk;
16809 } olist;
16810
16811 //close//
16812 typedef struct
16813 {       flag cerr;
16814         ftnint cunit;
16815         char *csta;
16816 } cllist;
16817
16818 //rewind, backspace, endfile//
16819 typedef struct
16820 {       flag aerr;
16821         ftnint aunit;
16822 } alist;
16823
16824 // inquire //
16825 typedef struct
16826 {       flag inerr;
16827         ftnint inunit;
16828         char *infile;
16829         ftnlen infilen;
16830         ftnint  *inex;  //parameters in standard's order//
16831         ftnint  *inopen;
16832         ftnint  *innum;
16833         ftnint  *innamed;
16834         char    *inname;
16835         ftnlen  innamlen;
16836         char    *inacc;
16837         ftnlen  inacclen;
16838         char    *inseq;
16839         ftnlen  inseqlen;
16840         char    *indir;
16841         ftnlen  indirlen;
16842         char    *infmt;
16843         ftnlen  infmtlen;
16844         char    *inform;
16845         ftnint  informlen;
16846         char    *inunf;
16847         ftnlen  inunflen;
16848         ftnint  *inrecl;
16849         ftnint  *innrec;
16850         char    *inblank;
16851         ftnlen  inblanklen;
16852 } inlist;
16853
16854
16855
16856 union Multitype {       // for multiple entry points //
16857         integer1 g;
16858         shortint h;
16859         integer i;
16860         // longint j; //
16861         real r;
16862         doublereal d;
16863         complex c;
16864         doublecomplex z;
16865         };
16866
16867 typedef union Multitype Multitype;
16868
16869 typedef long Long;      // No longer used; formerly in Namelist //
16870
16871 struct Vardesc {        // for Namelist //
16872         char *name;
16873         char *addr;
16874         ftnlen *dims;
16875         int  type;
16876         };
16877 typedef struct Vardesc Vardesc;
16878
16879 struct Namelist {
16880         char *name;
16881         Vardesc **vars;
16882         int nvars;
16883         };
16884 typedef struct Namelist Namelist;
16885
16886
16887
16888
16889
16890
16891
16892
16893 // procedure parameter types for -A and -C++ //
16894
16895
16896
16897
16898 typedef int // Unknown procedure type // (*U_fp)();
16899 typedef shortint (*J_fp)();
16900 typedef integer (*I_fp)();
16901 typedef real (*R_fp)();
16902 typedef doublereal (*D_fp)(), (*E_fp)();
16903 typedef // Complex // void  (*C_fp)();
16904 typedef // Double Complex // void  (*Z_fp)();
16905 typedef logical (*L_fp)();
16906 typedef shortlogical (*K_fp)();
16907 typedef // Character // void  (*H_fp)();
16908 typedef // Subroutine // int (*S_fp)();
16909
16910 // E_fp is for real functions when -R is not specified //
16911 typedef void  C_f;      // complex function //
16912 typedef void  H_f;      // character function //
16913 typedef void  Z_f;      // double complex function //
16914 typedef doublereal E_f; // real function with -R not specified //
16915
16916 // undef any lower-case symbols that your C compiler predefines, e.g.: //
16917
16918
16919 // (No such symbols should be defined in a strict ANSI C compiler.
16920    We can avoid trouble with f2c-translated code by using
16921    gcc -ansi [-traditional].) //
16922
16923
16924
16925
16926
16927
16928
16929
16930
16931
16932
16933
16934
16935
16936
16937
16938
16939
16940
16941
16942
16943
16944
16945 // Main program // MAIN__()
16946 {
16947     // System generated locals //
16948     integer i__1;
16949     real r__1, r__2;
16950     doublereal d__1, d__2;
16951     complex q__1;
16952     doublecomplex z__1, z__2, z__3;
16953     logical L__1;
16954     char ch__1[1];
16955
16956     // Builtin functions //
16957     void c_div();
16958     integer pow_ii();
16959     double pow_ri(), pow_di();
16960     void pow_ci();
16961     double pow_dd();
16962     void pow_zz();
16963     double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
16964             asin(), atan(), atan2(), c_abs();
16965     void c_cos(), c_exp(), c_log(), r_cnjg();
16966     double cos(), cosh();
16967     void c_sin(), c_sqrt();
16968     double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
16969             d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
16970     integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
16971     logical l_ge(), l_gt(), l_le(), l_lt();
16972     integer i_nint();
16973     double r_sign();
16974
16975     // Local variables //
16976     extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
16977             fool_(), fooz_(), getem_();
16978     static char a1[10], a2[10];
16979     static complex c1, c2;
16980     static doublereal d1, d2;
16981     static integer i1, i2;
16982     static real r1, r2;
16983
16984
16985     getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
16986 // / //
16987     i__1 = i1 / i2;
16988     fooi_(&i__1);
16989     r__1 = r1 / i1;
16990     foor_(&r__1);
16991     d__1 = d1 / i1;
16992     food_(&d__1);
16993     d__1 = (doublereal) i1;
16994     q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
16995     fooc_(&q__1);
16996     r__1 = r1 / r2;
16997     foor_(&r__1);
16998     d__1 = r1 / d1;
16999     food_(&d__1);
17000     d__1 = d1 / d2;
17001     food_(&d__1);
17002     d__1 = d1 / r1;
17003     food_(&d__1);
17004     c_div(&q__1, &c1, &c2);
17005     fooc_(&q__1);
17006     q__1.r = c1.r / r1, q__1.i = c1.i / r1;
17007     fooc_(&q__1);
17008     z__1.r = c1.r / d1, z__1.i = c1.i / d1;
17009     fooz_(&z__1);
17010 // ** //
17011     i__1 = pow_ii(&i1, &i2);
17012     fooi_(&i__1);
17013     r__1 = pow_ri(&r1, &i1);
17014     foor_(&r__1);
17015     d__1 = pow_di(&d1, &i1);
17016     food_(&d__1);
17017     pow_ci(&q__1, &c1, &i1);
17018     fooc_(&q__1);
17019     d__1 = (doublereal) r1;
17020     d__2 = (doublereal) r2;
17021     r__1 = pow_dd(&d__1, &d__2);
17022     foor_(&r__1);
17023     d__2 = (doublereal) r1;
17024     d__1 = pow_dd(&d__2, &d1);
17025     food_(&d__1);
17026     d__1 = pow_dd(&d1, &d2);
17027     food_(&d__1);
17028     d__2 = (doublereal) r1;
17029     d__1 = pow_dd(&d1, &d__2);
17030     food_(&d__1);
17031     z__2.r = c1.r, z__2.i = c1.i;
17032     z__3.r = c2.r, z__3.i = c2.i;
17033     pow_zz(&z__1, &z__2, &z__3);
17034     q__1.r = z__1.r, q__1.i = z__1.i;
17035     fooc_(&q__1);
17036     z__2.r = c1.r, z__2.i = c1.i;
17037     z__3.r = r1, z__3.i = 0.;
17038     pow_zz(&z__1, &z__2, &z__3);
17039     q__1.r = z__1.r, q__1.i = z__1.i;
17040     fooc_(&q__1);
17041     z__2.r = c1.r, z__2.i = c1.i;
17042     z__3.r = d1, z__3.i = 0.;
17043     pow_zz(&z__1, &z__2, &z__3);
17044     fooz_(&z__1);
17045 // FFEINTRIN_impABS //
17046     r__1 = (doublereal)((  r1  ) >= 0 ? (  r1  ) : -(  r1  ))  ;
17047     foor_(&r__1);
17048 // FFEINTRIN_impACOS //
17049     r__1 = acos(r1);
17050     foor_(&r__1);
17051 // FFEINTRIN_impAIMAG //
17052     r__1 = r_imag(&c1);
17053     foor_(&r__1);
17054 // FFEINTRIN_impAINT //
17055     r__1 = r_int(&r1);
17056     foor_(&r__1);
17057 // FFEINTRIN_impALOG //
17058     r__1 = log(r1);
17059     foor_(&r__1);
17060 // FFEINTRIN_impALOG10 //
17061     r__1 = r_lg10(&r1);
17062     foor_(&r__1);
17063 // FFEINTRIN_impAMAX0 //
17064     r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
17065     foor_(&r__1);
17066 // FFEINTRIN_impAMAX1 //
17067     r__1 = (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
17068     foor_(&r__1);
17069 // FFEINTRIN_impAMIN0 //
17070     r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
17071     foor_(&r__1);
17072 // FFEINTRIN_impAMIN1 //
17073     r__1 = (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
17074     foor_(&r__1);
17075 // FFEINTRIN_impAMOD //
17076     r__1 = r_mod(&r1, &r2);
17077     foor_(&r__1);
17078 // FFEINTRIN_impANINT //
17079     r__1 = r_nint(&r1);
17080     foor_(&r__1);
17081 // FFEINTRIN_impASIN //
17082     r__1 = asin(r1);
17083     foor_(&r__1);
17084 // FFEINTRIN_impATAN //
17085     r__1 = atan(r1);
17086     foor_(&r__1);
17087 // FFEINTRIN_impATAN2 //
17088     r__1 = atan2(r1, r2);
17089     foor_(&r__1);
17090 // FFEINTRIN_impCABS //
17091     r__1 = c_abs(&c1);
17092     foor_(&r__1);
17093 // FFEINTRIN_impCCOS //
17094     c_cos(&q__1, &c1);
17095     fooc_(&q__1);
17096 // FFEINTRIN_impCEXP //
17097     c_exp(&q__1, &c1);
17098     fooc_(&q__1);
17099 // FFEINTRIN_impCHAR //
17100     *(unsigned char *)&ch__1[0] = i1;
17101     fooa_(ch__1, 1L);
17102 // FFEINTRIN_impCLOG //
17103     c_log(&q__1, &c1);
17104     fooc_(&q__1);
17105 // FFEINTRIN_impCONJG //
17106     r_cnjg(&q__1, &c1);
17107     fooc_(&q__1);
17108 // FFEINTRIN_impCOS //
17109     r__1 = cos(r1);
17110     foor_(&r__1);
17111 // FFEINTRIN_impCOSH //
17112     r__1 = cosh(r1);
17113     foor_(&r__1);
17114 // FFEINTRIN_impCSIN //
17115     c_sin(&q__1, &c1);
17116     fooc_(&q__1);
17117 // FFEINTRIN_impCSQRT //
17118     c_sqrt(&q__1, &c1);
17119     fooc_(&q__1);
17120 // FFEINTRIN_impDABS //
17121     d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
17122     food_(&d__1);
17123 // FFEINTRIN_impDACOS //
17124     d__1 = acos(d1);
17125     food_(&d__1);
17126 // FFEINTRIN_impDASIN //
17127     d__1 = asin(d1);
17128     food_(&d__1);
17129 // FFEINTRIN_impDATAN //
17130     d__1 = atan(d1);
17131     food_(&d__1);
17132 // FFEINTRIN_impDATAN2 //
17133     d__1 = atan2(d1, d2);
17134     food_(&d__1);
17135 // FFEINTRIN_impDCOS //
17136     d__1 = cos(d1);
17137     food_(&d__1);
17138 // FFEINTRIN_impDCOSH //
17139     d__1 = cosh(d1);
17140     food_(&d__1);
17141 // FFEINTRIN_impDDIM //
17142     d__1 = d_dim(&d1, &d2);
17143     food_(&d__1);
17144 // FFEINTRIN_impDEXP //
17145     d__1 = exp(d1);
17146     food_(&d__1);
17147 // FFEINTRIN_impDIM //
17148     r__1 = r_dim(&r1, &r2);
17149     foor_(&r__1);
17150 // FFEINTRIN_impDINT //
17151     d__1 = d_int(&d1);
17152     food_(&d__1);
17153 // FFEINTRIN_impDLOG //
17154     d__1 = log(d1);
17155     food_(&d__1);
17156 // FFEINTRIN_impDLOG10 //
17157     d__1 = d_lg10(&d1);
17158     food_(&d__1);
17159 // FFEINTRIN_impDMAX1 //
17160     d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
17161     food_(&d__1);
17162 // FFEINTRIN_impDMIN1 //
17163     d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
17164     food_(&d__1);
17165 // FFEINTRIN_impDMOD //
17166     d__1 = d_mod(&d1, &d2);
17167     food_(&d__1);
17168 // FFEINTRIN_impDNINT //
17169     d__1 = d_nint(&d1);
17170     food_(&d__1);
17171 // FFEINTRIN_impDPROD //
17172     d__1 = (doublereal) r1 * r2;
17173     food_(&d__1);
17174 // FFEINTRIN_impDSIGN //
17175     d__1 = d_sign(&d1, &d2);
17176     food_(&d__1);
17177 // FFEINTRIN_impDSIN //
17178     d__1 = sin(d1);
17179     food_(&d__1);
17180 // FFEINTRIN_impDSINH //
17181     d__1 = sinh(d1);
17182     food_(&d__1);
17183 // FFEINTRIN_impDSQRT //
17184     d__1 = sqrt(d1);
17185     food_(&d__1);
17186 // FFEINTRIN_impDTAN //
17187     d__1 = tan(d1);
17188     food_(&d__1);
17189 // FFEINTRIN_impDTANH //
17190     d__1 = tanh(d1);
17191     food_(&d__1);
17192 // FFEINTRIN_impEXP //
17193     r__1 = exp(r1);
17194     foor_(&r__1);
17195 // FFEINTRIN_impIABS //
17196     i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
17197     fooi_(&i__1);
17198 // FFEINTRIN_impICHAR //
17199     i__1 = *(unsigned char *)a1;
17200     fooi_(&i__1);
17201 // FFEINTRIN_impIDIM //
17202     i__1 = i_dim(&i1, &i2);
17203     fooi_(&i__1);
17204 // FFEINTRIN_impIDNINT //
17205     i__1 = i_dnnt(&d1);
17206     fooi_(&i__1);
17207 // FFEINTRIN_impINDEX //
17208     i__1 = i_indx(a1, a2, 10L, 10L);
17209     fooi_(&i__1);
17210 // FFEINTRIN_impISIGN //
17211     i__1 = i_sign(&i1, &i2);
17212     fooi_(&i__1);
17213 // FFEINTRIN_impLEN //
17214     i__1 = i_len(a1, 10L);
17215     fooi_(&i__1);
17216 // FFEINTRIN_impLGE //
17217     L__1 = l_ge(a1, a2, 10L, 10L);
17218     fool_(&L__1);
17219 // FFEINTRIN_impLGT //
17220     L__1 = l_gt(a1, a2, 10L, 10L);
17221     fool_(&L__1);
17222 // FFEINTRIN_impLLE //
17223     L__1 = l_le(a1, a2, 10L, 10L);
17224     fool_(&L__1);
17225 // FFEINTRIN_impLLT //
17226     L__1 = l_lt(a1, a2, 10L, 10L);
17227     fool_(&L__1);
17228 // FFEINTRIN_impMAX0 //
17229     i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
17230     fooi_(&i__1);
17231 // FFEINTRIN_impMAX1 //
17232     i__1 = (integer) (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
17233     fooi_(&i__1);
17234 // FFEINTRIN_impMIN0 //
17235     i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
17236     fooi_(&i__1);
17237 // FFEINTRIN_impMIN1 //
17238     i__1 = (integer) (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
17239     fooi_(&i__1);
17240 // FFEINTRIN_impMOD //
17241     i__1 = i1 % i2;
17242     fooi_(&i__1);
17243 // FFEINTRIN_impNINT //
17244     i__1 = i_nint(&r1);
17245     fooi_(&i__1);
17246 // FFEINTRIN_impSIGN //
17247     r__1 = r_sign(&r1, &r2);
17248     foor_(&r__1);
17249 // FFEINTRIN_impSIN //
17250     r__1 = sin(r1);
17251     foor_(&r__1);
17252 // FFEINTRIN_impSINH //
17253     r__1 = sinh(r1);
17254     foor_(&r__1);
17255 // FFEINTRIN_impSQRT //
17256     r__1 = sqrt(r1);
17257     foor_(&r__1);
17258 // FFEINTRIN_impTAN //
17259     r__1 = tan(r1);
17260     foor_(&r__1);
17261 // FFEINTRIN_impTANH //
17262     r__1 = tanh(r1);
17263     foor_(&r__1);
17264 // FFEINTRIN_imp_CMPLX_C //
17265     r__1 = c1.r;
17266     r__2 = c2.r;
17267     q__1.r = r__1, q__1.i = r__2;
17268     fooc_(&q__1);
17269 // FFEINTRIN_imp_CMPLX_D //
17270     z__1.r = d1, z__1.i = d2;
17271     fooz_(&z__1);
17272 // FFEINTRIN_imp_CMPLX_I //
17273     r__1 = (real) i1;
17274     r__2 = (real) i2;
17275     q__1.r = r__1, q__1.i = r__2;
17276     fooc_(&q__1);
17277 // FFEINTRIN_imp_CMPLX_R //
17278     q__1.r = r1, q__1.i = r2;
17279     fooc_(&q__1);
17280 // FFEINTRIN_imp_DBLE_C //
17281     d__1 = (doublereal) c1.r;
17282     food_(&d__1);
17283 // FFEINTRIN_imp_DBLE_D //
17284     d__1 = d1;
17285     food_(&d__1);
17286 // FFEINTRIN_imp_DBLE_I //
17287     d__1 = (doublereal) i1;
17288     food_(&d__1);
17289 // FFEINTRIN_imp_DBLE_R //
17290     d__1 = (doublereal) r1;
17291     food_(&d__1);
17292 // FFEINTRIN_imp_INT_C //
17293     i__1 = (integer) c1.r;
17294     fooi_(&i__1);
17295 // FFEINTRIN_imp_INT_D //
17296     i__1 = (integer) d1;
17297     fooi_(&i__1);
17298 // FFEINTRIN_imp_INT_I //
17299     i__1 = i1;
17300     fooi_(&i__1);
17301 // FFEINTRIN_imp_INT_R //
17302     i__1 = (integer) r1;
17303     fooi_(&i__1);
17304 // FFEINTRIN_imp_REAL_C //
17305     r__1 = c1.r;
17306     foor_(&r__1);
17307 // FFEINTRIN_imp_REAL_D //
17308     r__1 = (real) d1;
17309     foor_(&r__1);
17310 // FFEINTRIN_imp_REAL_I //
17311     r__1 = (real) i1;
17312     foor_(&r__1);
17313 // FFEINTRIN_imp_REAL_R //
17314     r__1 = r1;
17315     foor_(&r__1);
17316
17317 // FFEINTRIN_imp_INT_D: //
17318
17319 // FFEINTRIN_specIDINT //
17320     i__1 = (integer) d1;
17321     fooi_(&i__1);
17322
17323 // FFEINTRIN_imp_INT_R: //
17324
17325 // FFEINTRIN_specIFIX //
17326     i__1 = (integer) r1;
17327     fooi_(&i__1);
17328 // FFEINTRIN_specINT //
17329     i__1 = (integer) r1;
17330     fooi_(&i__1);
17331
17332 // FFEINTRIN_imp_REAL_D: //
17333
17334 // FFEINTRIN_specSNGL //
17335     r__1 = (real) d1;
17336     foor_(&r__1);
17337
17338 // FFEINTRIN_imp_REAL_I: //
17339
17340 // FFEINTRIN_specFLOAT //
17341     r__1 = (real) i1;
17342     foor_(&r__1);
17343 // FFEINTRIN_specREAL //
17344     r__1 = (real) i1;
17345     foor_(&r__1);
17346
17347 } // MAIN__ //
17348
17349 -------- (end output file from f2c)
17350
17351 */