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.j"
  92 #include "rtl.j"
  93 #include "toplev.j"
  94 #include "tree.j"
  95 #include "output.j"  /* Must follow tree.j so TREE_CODE is defined! */
  96 #include "convert.j"
  97 #include "ggc.j"
  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 /* tree.h declares a bunch of stuff that it expects the front end to
 221    define.  Here are the definitions, which in the C front end are
 222    found in the file c-decl.c.  */
 223
 224 tree current_function_decl;
 225
 226 /* ~~gcc/tree.h *should* declare this, because toplev.c and dwarfout.c
 227    reference it.  */
 228
 229 const char * const language_string = "GNU F77";
 230
 231 /* Stream for reading from the input file.  */
 232 FILE *finput;
 233
 234 /* These definitions parallel those in c-decl.c so that code from that
 235    module can be used pretty much as is.  Much of these defs aren't
 236    otherwise used, i.e. by g77 code per se, except some of them are used
 237    to build some of them that are.  The ones that are global (i.e. not
 238    "static") are those that ste.c and such might use (directly
 239    or by using com macros that reference them in their definitions).  */
 240
 241 tree string_type_node;
 242
 243 /* The rest of these are inventions for g77, though there might be
 244    similar things in the C front end.  As they are found, these
 245    inventions should be renamed to be canonical.  Note that only
 246    the ones currently required to be global are so.  */
 247
 248 static tree ffecom_tree_fun_type_void;
 249
 250 tree ffecom_integer_type_node;  /* Abbrev for _tree_type[blah][blah]. */
 251 tree ffecom_integer_zero_node;  /* Like *_*_* with g77's integer type. */
 252 tree ffecom_integer_one_node;   /* " */
 253 tree ffecom_tree_type[FFEINFO_basictype][FFEINFO_kindtype];
 254
 255 /* _fun_type things are the f2c-specific versions.  For -fno-f2c,
 256    just use build_function_type and build_pointer_type on the
 257    appropriate _tree_type array element.  */
 258
 259 static tree ffecom_tree_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
 260 static tree ffecom_tree_ptr_to_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
 261 static tree ffecom_tree_subr_type;
 262 static tree ffecom_tree_ptr_to_subr_type;
 263 static tree ffecom_tree_blockdata_type;
 264
 265 static tree ffecom_tree_xargc_;
 266
 267 ffecomSymbol ffecom_symbol_null_
 268 =
 269 {
 270   NULL_TREE,
 271   NULL_TREE,
 272   NULL_TREE,
 273   NULL_TREE,
 274   false
 275 };
 276 ffeinfoKindtype ffecom_pointer_kind_ = FFEINFO_basictypeNONE;
 277 ffeinfoKindtype ffecom_label_kind_ = FFEINFO_basictypeNONE;
 278
 279 int ffecom_f2c_typecode_[FFEINFO_basictype][FFEINFO_kindtype];
 280 tree ffecom_f2c_integer_type_node;
 281 tree ffecom_f2c_ptr_to_integer_type_node;
 282 tree ffecom_f2c_address_type_node;
 283 tree ffecom_f2c_real_type_node;
 284 tree ffecom_f2c_ptr_to_real_type_node;
 285 tree ffecom_f2c_doublereal_type_node;
 286 tree ffecom_f2c_complex_type_node;
 287 tree ffecom_f2c_doublecomplex_type_node;
 288 tree ffecom_f2c_longint_type_node;
 289 tree ffecom_f2c_logical_type_node;
 290 tree ffecom_f2c_flag_type_node;
 291 tree ffecom_f2c_ftnlen_type_node;
 292 tree ffecom_f2c_ftnlen_zero_node;
 293 tree ffecom_f2c_ftnlen_one_node;
 294 tree ffecom_f2c_ftnlen_two_node;
 295 tree ffecom_f2c_ptr_to_ftnlen_type_node;
 296 tree ffecom_f2c_ftnint_type_node;
 297 tree ffecom_f2c_ptr_to_ftnint_type_node;
 298 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 299
 300 /* Simple definitions and enumerations. */
 301
 302 #ifndef FFECOM_sizeMAXSTACKITEM
 303 #define FFECOM_sizeMAXSTACKITEM 32*1024 /* Keep user-declared things
 304                                            larger than this # bytes
 305                                            off stack if possible. */
 306 #endif
 307
 308 /* For systems that have large enough stacks, they should define
 309    this to 0, and here, for ease of use later on, we just undefine
 310    it if it is 0.  */
 311
 312 #if FFECOM_sizeMAXSTACKITEM == 0
 313 #undef FFECOM_sizeMAXSTACKITEM
 314 #endif
 315
 316 typedef enum
 317   {
 318     FFECOM_rttypeVOID_,
 319     FFECOM_rttypeVOIDSTAR_,     /* C's `void *' type. */
 320     FFECOM_rttypeFTNINT_,       /* f2c's `ftnint' type. */
 321     FFECOM_rttypeINTEGER_,      /* f2c's `integer' type. */
 322     FFECOM_rttypeLONGINT_,      /* f2c's `longint' type. */
 323     FFECOM_rttypeLOGICAL_,      /* f2c's `logical' type. */
 324     FFECOM_rttypeREAL_F2C_,     /* f2c's `real' returned as `double'. */
 325     FFECOM_rttypeREAL_GNU_,     /* `real' returned as such. */
 326     FFECOM_rttypeCOMPLEX_F2C_,  /* f2c's `complex' returned via 1st arg. */
 327     FFECOM_rttypeCOMPLEX_GNU_,  /* f2c's `complex' returned directly. */
 328     FFECOM_rttypeDOUBLE_,       /* C's `double' type. */
 329     FFECOM_rttypeDOUBLEREAL_,   /* f2c's `doublereal' type. */
 330     FFECOM_rttypeDBLCMPLX_F2C_, /* f2c's `doublecomplex' returned via 1st arg. */
 331     FFECOM_rttypeDBLCMPLX_GNU_, /* f2c's `doublecomplex' returned directly. */
 332     FFECOM_rttypeCHARACTER_,    /* f2c `char *'/`ftnlen' pair. */
 333     FFECOM_rttype_
 334   } ffecomRttype_;
 335
 336 /* Internal typedefs. */
 337
 338 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 339 typedef struct _ffecom_concat_list_ ffecomConcatList_;
 340 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 341
 342 /* Private include files. */
 343
 344
 345 /* Internal structure definitions. */
 346
 347 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 348 struct _ffecom_concat_list_
 349   {
 350     ffebld *exprs;
 351     int count;
 352     int max;
 353     ffetargetCharacterSize minlen;
 354     ffetargetCharacterSize maxlen;
 355   };
 356 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 357
 358 /* Static functions (internal). */
 359
 360 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 361 static tree ffecom_arglist_expr_ (const char *argstring, ffebld args);
 362 static tree ffecom_widest_expr_type_ (ffebld list);
 363 static bool ffecom_overlap_ (tree dest_decl, tree dest_offset,
 364                              tree dest_size, tree source_tree,
 365                              ffebld source, bool scalar_arg);
 366 static bool ffecom_args_overlapping_ (tree dest_tree, ffebld dest,
 367                                       tree args, tree callee_commons,
 368                                       bool scalar_args);
 369 static tree ffecom_build_f2c_string_ (int i, const char *s);
 370 static tree ffecom_call_ (tree fn, ffeinfoKindtype kt,
 371                           bool is_f2c_complex, tree type,
 372                           tree args, tree dest_tree,
 373                           ffebld dest, bool *dest_used,
 374                           tree callee_commons, bool scalar_args, tree hook);
 375 static tree ffecom_call_binop_ (tree fn, ffeinfoKindtype kt,
 376                                 bool is_f2c_complex, tree type,
 377                                 ffebld left, ffebld right,
 378                                 tree dest_tree, ffebld dest,
 379                                 bool *dest_used, tree callee_commons,
 380                                 bool scalar_args, tree hook);
 381 static void ffecom_char_args_x_ (tree *xitem, tree *length,
 382                                  ffebld expr, bool with_null);
 383 static tree ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy);
 384 static tree ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s);
 385 static ffecomConcatList_
 386   ffecom_concat_list_gather_ (ffecomConcatList_ catlist,
 387                               ffebld expr,
 388                               ffetargetCharacterSize max);
 389 static void ffecom_concat_list_kill_ (ffecomConcatList_ catlist);
 390 static ffecomConcatList_ ffecom_concat_list_new_ (ffebld expr,
 391                                                 ffetargetCharacterSize max);
 392 static void ffecom_debug_kludge_ (tree aggr, const char *aggr_type,
 393                                   ffesymbol member, tree member_type,
 394                                   ffetargetOffset offset);
 395 static void ffecom_do_entry_ (ffesymbol fn, int entrynum);
 396 static tree ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
 397                           bool *dest_used, bool assignp, bool widenp);
 398 static tree ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
 399                                     ffebld dest, bool *dest_used);
 400 static tree ffecom_expr_power_integer_ (ffebld expr);
 401 static void ffecom_expr_transform_ (ffebld expr);
 402 static void ffecom_f2c_make_type_ (tree *type, int tcode, const char *name);
 403 static void ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
 404                                       int code);
 405 static ffeglobal ffecom_finish_global_ (ffeglobal global);
 406 static ffesymbol ffecom_finish_symbol_transform_ (ffesymbol s);
 407 static tree ffecom_get_appended_identifier_ (char us, const char *text);
 408 static tree ffecom_get_external_identifier_ (ffesymbol s);
 409 static tree ffecom_get_identifier_ (const char *text);
 410 static tree ffecom_gen_sfuncdef_ (ffesymbol s,
 411                                   ffeinfoBasictype bt,
 412                                   ffeinfoKindtype kt);
 413 static const char *ffecom_gfrt_args_ (ffecomGfrt ix);
 414 static tree ffecom_gfrt_tree_ (ffecomGfrt ix);
 415 static tree ffecom_init_zero_ (tree decl);
 416 static tree ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
 417                                      tree *maybe_tree);
 418 static tree ffecom_intrinsic_len_ (ffebld expr);
 419 static void ffecom_let_char_ (tree dest_tree,
 420                               tree dest_length,
 421                               ffetargetCharacterSize dest_size,
 422                               ffebld source);
 423 static void ffecom_make_gfrt_ (ffecomGfrt ix);
 424 static void ffecom_member_phase1_ (ffestorag mst, ffestorag st);
 425 static void ffecom_member_phase2_ (ffestorag mst, ffestorag st);
 426 static void ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size,
 427                                       ffebld source);
 428 static void ffecom_push_dummy_decls_ (ffebld dumlist,
 429                                       bool stmtfunc);
 430 static void ffecom_start_progunit_ (void);
 431 static ffesymbol ffecom_sym_transform_ (ffesymbol s);
 432 static ffesymbol ffecom_sym_transform_assign_ (ffesymbol s);
 433 static void ffecom_transform_common_ (ffesymbol s);
 434 static void ffecom_transform_equiv_ (ffestorag st);
 435 static tree ffecom_transform_namelist_ (ffesymbol s);
 436 static void ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
 437                                        tree t);
 438 static void ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
 439                                        tree *size, tree tree);
 440 static tree ffecom_tree_divide_ (tree tree_type, tree left, tree right,
 441                                  tree dest_tree, ffebld dest,
 442                                  bool *dest_used, tree hook);
 443 static tree ffecom_type_localvar_ (ffesymbol s,
 444                                    ffeinfoBasictype bt,
 445                                    ffeinfoKindtype kt);
 446 static tree ffecom_type_namelist_ (void);
 447 static tree ffecom_type_vardesc_ (void);
 448 static tree ffecom_vardesc_ (ffebld expr);
 449 static tree ffecom_vardesc_array_ (ffesymbol s);
 450 static tree ffecom_vardesc_dims_ (ffesymbol s);
 451 static tree ffecom_convert_narrow_ (tree type, tree expr);
 452 static tree ffecom_convert_widen_ (tree type, tree expr);
 453 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 454
 455 /* These are static functions that parallel those found in the C front
 456    end and thus have the same names.  */
 457
 458 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 459 static tree bison_rule_compstmt_ (void);
 460 static void bison_rule_pushlevel_ (void);
 461 static void delete_block (tree block);
 462 static int duplicate_decls (tree newdecl, tree olddecl);
 463 static void finish_decl (tree decl, tree init, bool is_top_level);
 464 static void finish_function (int nested);
 465 static const char *lang_printable_name (tree decl, int v);
 466 static tree lookup_name_current_level (tree name);
 467 static struct binding_level *make_binding_level (void);
 468 static void pop_f_function_context (void);
 469 static void push_f_function_context (void);
 470 static void push_parm_decl (tree parm);
 471 static tree pushdecl_top_level (tree decl);
 472 static int kept_level_p (void);
 473 static tree storedecls (tree decls);
 474 static void store_parm_decls (int is_main_program);
 475 static tree start_decl (tree decl, bool is_top_level);
 476 static void start_function (tree name, tree type, int nested, int public);
 477 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 478 #if FFECOM_GCC_INCLUDE
 479 static void ffecom_file_ (const char *name);
 480 static void ffecom_initialize_char_syntax_ (void);
 481 static void ffecom_close_include_ (FILE *f);
 482 static int ffecom_decode_include_option_ (char *spec);
 483 static FILE *ffecom_open_include_ (char *name, ffewhereLine l,
 484                                    ffewhereColumn c);
 485 #endif  /* FFECOM_GCC_INCLUDE */
 486
 487 /* Static objects accessed by functions in this module. */
 488
 489 static ffesymbol ffecom_primary_entry_ = NULL;
 490 static ffesymbol ffecom_nested_entry_ = NULL;
 491 static ffeinfoKind ffecom_primary_entry_kind_;
 492 static bool ffecom_primary_entry_is_proc_;
 493 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 494 static tree ffecom_outer_function_decl_;
 495 static tree ffecom_previous_function_decl_;
 496 static tree ffecom_which_entrypoint_decl_;
 497 static tree ffecom_float_zero_ = NULL_TREE;
 498 static tree ffecom_float_half_ = NULL_TREE;
 499 static tree ffecom_double_zero_ = NULL_TREE;
 500 static tree ffecom_double_half_ = NULL_TREE;
 501 static tree ffecom_func_result_;/* For functions. */
 502 static tree ffecom_func_length_;/* For CHARACTER fns. */
 503 static ffebld ffecom_list_blockdata_;
 504 static ffebld ffecom_list_common_;
 505 static ffebld ffecom_master_arglist_;
 506 static ffeinfoBasictype ffecom_master_bt_;
 507 static ffeinfoKindtype ffecom_master_kt_;
 508 static ffetargetCharacterSize ffecom_master_size_;
 509 static int ffecom_num_fns_ = 0;
 510 static int ffecom_num_entrypoints_ = 0;
 511 static bool ffecom_is_altreturning_ = FALSE;
 512 static tree ffecom_multi_type_node_;
 513 static tree ffecom_multi_retval_;
 514 static tree
 515   ffecom_multi_fields_[FFEINFO_basictype][FFEINFO_kindtype];
 516 static bool ffecom_member_namelisted_;  /* _member_phase1_ namelisted? */
 517 static bool ffecom_doing_entry_ = FALSE;
 518 static bool ffecom_transform_only_dummies_ = FALSE;
 519 static int ffecom_typesize_pointer_;
 520 static int ffecom_typesize_integer1_;
 521
 522 /* Holds pointer-to-function expressions.  */
 523
 524 static tree ffecom_gfrt_[FFECOM_gfrt]
 525 =
 526 {
 527 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) NULL_TREE,
 528 #include "com-rt.def"
 529 #undef DEFGFRT
 530 };
 531
 532 /* Holds the external names of the functions.  */
 533
 534 static const char *ffecom_gfrt_name_[FFECOM_gfrt]
 535 =
 536 {
 537 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) NAME,
 538 #include "com-rt.def"
 539 #undef DEFGFRT
 540 };
 541
 542 /* Whether the function returns.  */
 543
 544 static bool ffecom_gfrt_volatile_[FFECOM_gfrt]
 545 =
 546 {
 547 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) VOLATILE,
 548 #include "com-rt.def"
 549 #undef DEFGFRT
 550 };
 551
 552 /* Whether the function returns type complex.  */
 553
 554 static bool ffecom_gfrt_complex_[FFECOM_gfrt]
 555 =
 556 {
 557 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) COMPLEX,
 558 #include "com-rt.def"
 559 #undef DEFGFRT
 560 };
 561
 562 /* Type code for the function return value.  */
 563
 564 static ffecomRttype_ ffecom_gfrt_type_[FFECOM_gfrt]
 565 =
 566 {
 567 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) TYPE,
 568 #include "com-rt.def"
 569 #undef DEFGFRT
 570 };
 571
 572 /* String of codes for the function's arguments.  */
 573
 574 static const char *ffecom_gfrt_argstring_[FFECOM_gfrt]
 575 =
 576 {
 577 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) ARGS,
 578 #include "com-rt.def"
 579 #undef DEFGFRT
 580 };
 581 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 582
 583 /* Internal macros. */
 584
 585 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 586
 587 /* We let tm.h override the types used here, to handle trivial differences
 588    such as the choice of unsigned int or long unsigned int for size_t.
 589    When machines start needing nontrivial differences in the size type,
 590    it would be best to do something here to figure out automatically
 591    from other information what type to use.  */
 592
 593 #ifndef SIZE_TYPE
 594 #define SIZE_TYPE "long unsigned int"
 595 #endif
 596
 597 #define ffecom_concat_list_count_(catlist) ((catlist).count)
 598 #define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)])
 599 #define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen)
 600 #define ffecom_concat_list_minlen_(catlist) ((catlist).minlen)
 601
 602 #define ffecom_char_args_(i,l,e) ffecom_char_args_x_((i),(l),(e),FALSE)
 603 #define ffecom_char_args_with_null_(i,l,e) ffecom_char_args_x_((i),(l),(e),TRUE)
 604
 605 /* For each binding contour we allocate a binding_level structure
 606  * which records the names defined in that contour.
 607  * Contours include:
 608  *  0) the global one
 609  *  1) one for each function definition,
 610  *     where internal declarations of the parameters appear.
 611  *
 612  * The current meaning of a name can be found by searching the levels from
 613  * the current one out to the global one.
 614  */
 615
 616 /* Note that the information in the `names' component of the global contour
 617    is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers.  */
 618
 619 struct binding_level
 620   {
 621     /* A chain of _DECL nodes for all variables, constants, functions,
 622        and typedef types.  These are in the reverse of the order supplied.
 623      */
 624     tree names;
 625
 626     /* For each level (except not the global one),
 627        a chain of BLOCK nodes for all the levels
 628        that were entered and exited one level down.  */
 629     tree blocks;
 630
 631     /* The BLOCK node for this level, if one has been preallocated.
 632        If 0, the BLOCK is allocated (if needed) when the level is popped.  */
 633     tree this_block;
 634
 635     /* The binding level which this one is contained in (inherits from).  */
 636     struct binding_level *level_chain;
 637
 638     /* 0: no ffecom_prepare_* functions called at this level yet;
 639        1: ffecom_prepare* functions called, except not ffecom_prepare_end;
 640        2: ffecom_prepare_end called.  */
 641     int prep_state;
 642   };
 643
 644 #define NULL_BINDING_LEVEL (struct binding_level *) NULL
 645
 646 /* The binding level currently in effect.  */
 647
 648 static struct binding_level *current_binding_level;
 649
 650 /* A chain of binding_level structures awaiting reuse.  */
 651
 652 static struct binding_level *free_binding_level;
 653
 654 /* The outermost binding level, for names of file scope.
 655    This is created when the compiler is started and exists
 656    through the entire run.  */
 657
 658 static struct binding_level *global_binding_level;
 659
 660 /* Binding level structures are initialized by copying this one.  */
 661
 662 static struct binding_level clear_binding_level
 663 =
 664 {NULL, NULL, NULL, NULL_BINDING_LEVEL, 0};
 665
 666 /* Language-dependent contents of an identifier.  */
 667
 668 struct lang_identifier
 669   {
 670     struct tree_identifier ignore;
 671     tree global_value, local_value, label_value;
 672     bool invented;
 673   };
 674
 675 /* Macros for access to language-specific slots in an identifier.  */
 676 /* Each of these slots contains a DECL node or null.  */
 677
 678 /* This represents the value which the identifier has in the
 679    file-scope namespace.  */
 680 #define IDENTIFIER_GLOBAL_VALUE(NODE)   \
 681   (((struct lang_identifier *)(NODE))->global_value)
 682 /* This represents the value which the identifier has in the current
 683    scope.  */
 684 #define IDENTIFIER_LOCAL_VALUE(NODE)    \
 685   (((struct lang_identifier *)(NODE))->local_value)
 686 /* This represents the value which the identifier has as a label in
 687    the current label scope.  */
 688 #define IDENTIFIER_LABEL_VALUE(NODE)    \
 689   (((struct lang_identifier *)(NODE))->label_value)
 690 /* This is nonzero if the identifier was "made up" by g77 code.  */
 691 #define IDENTIFIER_INVENTED(NODE)       \
 692   (((struct lang_identifier *)(NODE))->invented)
 693
 694 /* In identifiers, C uses the following fields in a special way:
 695    TREE_PUBLIC        to record that there was a previous local extern decl.
 696    TREE_USED          to record that such a decl was used.
 697    TREE_ADDRESSABLE   to record that the address of such a decl was used.  */
 698
 699 /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
 700    that have names.  Here so we can clear out their names' definitions
 701    at the end of the function.  */
 702
 703 static tree named_labels;
 704
 705 /* A list of LABEL_DECLs from outer contexts that are currently shadowed.  */
 706
 707 static tree shadowed_labels;
 708
 709 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 710 \f
 711 /* Return the subscript expression, modified to do range-checking.
 712
 713    `array' is the array to be checked against.
 714    `element' is the subscript expression to check.
 715    `dim' is the dimension number (starting at 0).
 716    `total_dims' is the total number of dimensions (0 for CHARACTER substring).
 717 */
 718
 719 static tree
 720 ffecom_subscript_check_ (tree array, tree element, int dim, int total_dims,
 721                          char *array_name)
 722 {
 723   tree low = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 724   tree high = TYPE_MAX_VALUE (TYPE_DOMAIN (array));
 725   tree cond;
 726   tree die;
 727   tree args;
 728
 729   if (element == error_mark_node)
 730     return element;
 731
 732   if (TREE_TYPE (low) != TREE_TYPE (element))
 733     {
 734       if (TYPE_PRECISION (TREE_TYPE (low))
 735           > TYPE_PRECISION (TREE_TYPE (element)))
 736         element = convert (TREE_TYPE (low), element);
 737       else
 738         {
 739           low = convert (TREE_TYPE (element), low);
 740           if (high)
 741             high = convert (TREE_TYPE (element), high);
 742         }
 743     }
 744
 745   element = ffecom_save_tree (element);
 746   cond = ffecom_2 (LE_EXPR, integer_type_node,
 747                    low,
 748                    element);
 749   if (high)
 750     {
 751       cond = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
 752                        cond,
 753                        ffecom_2 (LE_EXPR, integer_type_node,
 754                                  element,
 755                                  high));
 756     }
 757
 758   {
 759     int len;
 760     char *proc;
 761     char *var;
 762     tree arg3;
 763     tree arg2;
 764     tree arg1;
 765     tree arg4;
 766
 767     switch (total_dims)
 768       {
 769       case 0:
 770         var = xmalloc (strlen (array_name) + 20);
 771         sprintf (&var[0], "%s[%s-substring]",
 772                  array_name,
 773                  dim ? "end" : "start");
 774         len = strlen (var) + 1;
 775         break;
 776
 777       case 1:
 778         len = strlen (array_name) + 1;
 779         var = array_name;
 780         break;
 781
 782       default:
 783         var = xmalloc (strlen (array_name) + 40);
 784         sprintf (&var[0], "%s[subscript-%d-of-%d]",
 785                  array_name,
 786                  dim + 1, total_dims);
 787         len = strlen (var) + 1;
 788         break;
 789       }
 790
 791     arg1 = build_string (len, var);
 792
 793     if (total_dims != 1)
 794       free (var);
 795
 796     TREE_TYPE (arg1)
 797       = build_type_variant (build_array_type (char_type_node,
 798                                               build_range_type
 799                                               (integer_type_node,
 800                                                integer_one_node,
 801                                                build_int_2 (len, 0))),
 802                             1, 0);
 803     TREE_CONSTANT (arg1) = 1;
 804     TREE_STATIC (arg1) = 1;
 805     arg1 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg1)),
 806                      arg1);
 807
 808     /* s_rnge adds one to the element to print it, so bias against
 809        that -- want to print a faithful *subscript* value.  */
 810     arg2 = convert (ffecom_f2c_ftnint_type_node,
 811                     ffecom_2 (MINUS_EXPR,
 812                               TREE_TYPE (element),
 813                               element,
 814                               convert (TREE_TYPE (element),
 815                                        integer_one_node)));
 816
 817     proc = xmalloc ((len = strlen (input_filename)
 818                      + IDENTIFIER_LENGTH (DECL_NAME (current_function_decl))
 819                      + 2));
 820
 821     sprintf (&proc[0], "%s/%s",
 822              input_filename,
 823              IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
 824     arg3 = build_string (len, proc);
 825
 826     free (proc);
 827
 828     TREE_TYPE (arg3)
 829       = build_type_variant (build_array_type (char_type_node,
 830                                               build_range_type
 831                                               (integer_type_node,
 832                                                integer_one_node,
 833                                                build_int_2 (len, 0))),
 834                             1, 0);
 835     TREE_CONSTANT (arg3) = 1;
 836     TREE_STATIC (arg3) = 1;
 837     arg3 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg3)),
 838                      arg3);
 839
 840     arg4 = convert (ffecom_f2c_ftnint_type_node,
 841                     build_int_2 (lineno, 0));
 842
 843     arg1 = build_tree_list (NULL_TREE, arg1);
 844     arg2 = build_tree_list (NULL_TREE, arg2);
 845     arg3 = build_tree_list (NULL_TREE, arg3);
 846     arg4 = build_tree_list (NULL_TREE, arg4);
 847     TREE_CHAIN (arg3) = arg4;
 848     TREE_CHAIN (arg2) = arg3;
 849     TREE_CHAIN (arg1) = arg2;
 850
 851     args = arg1;
 852   }
 853   die = ffecom_call_gfrt (FFECOM_gfrtRANGE,
 854                           args, NULL_TREE);
 855   TREE_SIDE_EFFECTS (die) = 1;
 856
 857   element = ffecom_3 (COND_EXPR,
 858                       TREE_TYPE (element),
 859                       cond,
 860                       element,
 861                       die);
 862
 863   return element;
 864 }
 865
 866 /* Return the computed element of an array reference.
 867
 868    `item' is NULL_TREE, or the transformed pointer to the array.
 869    `expr' is the original opARRAYREF expression, which is transformed
 870      if `item' is NULL_TREE.
 871    `want_ptr' is non-zero if a pointer to the element, instead of
 872      the element itself, is to be returned.  */
 873
 874 static tree
 875 ffecom_arrayref_ (tree item, ffebld expr, int want_ptr)
 876 {
 877   ffebld dims[FFECOM_dimensionsMAX];
 878   int i;
 879   int total_dims;
 880   int flatten = ffe_is_flatten_arrays ();
 881   int need_ptr;
 882   tree array;
 883   tree element;
 884   tree tree_type;
 885   tree tree_type_x;
 886   char *array_name;
 887   ffetype type;
 888   ffebld list;
 889
 890   if (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER)
 891     array_name = ffesymbol_text (ffebld_symter (ffebld_left (expr)));
 892   else
 893     array_name = "[expr?]";
 894
 895   /* Build up ARRAY_REFs in reverse order (since we're column major
 896      here in Fortran land). */
 897
 898   for (i = 0, list = ffebld_right (expr);
 899        list != NULL;
 900        ++i, list = ffebld_trail (list))
 901     {
 902       dims[i] = ffebld_head (list);
 903       type = ffeinfo_type (ffebld_basictype (dims[i]),
 904                            ffebld_kindtype (dims[i]));
 905       if (! flatten
 906           && ffecom_typesize_pointer_ > ffecom_typesize_integer1_
 907           && ffetype_size (type) > ffecom_typesize_integer1_)
 908         /* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit
 909            pointers and 32-bit integers.  Do the full 64-bit pointer
 910            arithmetic, for codes using arrays for nonstandard heap-like
 911            work.  */
 912         flatten = 1;
 913     }
 914
 915   total_dims = i;
 916
 917   need_ptr = want_ptr || flatten;
 918
 919   if (! item)
 920     {
 921       if (need_ptr)
 922         item = ffecom_ptr_to_expr (ffebld_left (expr));
 923       else
 924         item = ffecom_expr (ffebld_left (expr));
 925
 926       if (item == error_mark_node)
 927         return item;
 928
 929       if (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING
 930           && ! mark_addressable (item))
 931         return error_mark_node;
 932     }
 933
 934   if (item == error_mark_node)
 935     return item;
 936
 937   if (need_ptr)
 938     {
 939       tree min;
 940
 941       for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
 942            i >= 0;
 943            --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
 944         {
 945           min = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 946           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 947           if (flag_bounds_check)
 948             element = ffecom_subscript_check_ (array, element, i, total_dims,
 949                                                array_name);
 950           if (element == error_mark_node)
 951             return element;
 952
 953           /* Widen integral arithmetic as desired while preserving
 954              signedness.  */
 955           tree_type = TREE_TYPE (element);
 956           tree_type_x = tree_type;
 957           if (tree_type
 958               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
 959               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
 960             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
 961
 962           if (TREE_TYPE (min) != tree_type_x)
 963             min = convert (tree_type_x, min);
 964           if (TREE_TYPE (element) != tree_type_x)
 965             element = convert (tree_type_x, element);
 966
 967           item = ffecom_2 (PLUS_EXPR,
 968                            build_pointer_type (TREE_TYPE (array)),
 969                            item,
 970                            size_binop (MULT_EXPR,
 971                                        size_in_bytes (TREE_TYPE (array)),
 972                                        convert (sizetype,
 973                                                 fold (build (MINUS_EXPR,
 974                                                              tree_type_x,
 975                                                              element, min)))));
 976         }
 977       if (! want_ptr)
 978         {
 979           item = ffecom_1 (INDIRECT_REF,
 980                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
 981                            item);
 982         }
 983     }
 984   else
 985     {
 986       for (--i;
 987            i >= 0;
 988            --i)
 989         {
 990           array = TYPE_MAIN_VARIANT (TREE_TYPE (item));
 991
 992           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 993           if (flag_bounds_check)
 994             element = ffecom_subscript_check_ (array, element, i, total_dims,
 995                                                array_name);
 996           if (element == error_mark_node)
 997             return element;
 998
 999           /* Widen integral arithmetic as desired while preserving
1000              signedness.  */
1001           tree_type = TREE_TYPE (element);
1002           tree_type_x = tree_type;
1003           if (tree_type
1004               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
1005               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
1006             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
1007
1008           element = convert (tree_type_x, element);
1009
1010           item = ffecom_2 (ARRAY_REF,
1011                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
1012                            item,
1013                            element);
1014         }
1015     }
1016
1017   return item;
1018 }
1019
1020 /* This is like gcc's stabilize_reference -- in fact, most of the code
1021    comes from that -- but it handles the situation where the reference
1022    is going to have its subparts picked at, and it shouldn't change
1023    (or trigger extra invocations of functions in the subtrees) due to
1024    this.  save_expr is a bit overzealous, because we don't need the
1025    entire thing calculated and saved like a temp.  So, for DECLs, no
1026    change is needed, because these are stable aggregates, and ARRAY_REF
1027    and such might well be stable too, but for things like calculations,
1028    we do need to calculate a snapshot of a value before picking at it.  */
1029
1030 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1031 static tree
1032 ffecom_stabilize_aggregate_ (tree ref)
1033 {
1034   tree result;
1035   enum tree_code code = TREE_CODE (ref);
1036
1037   switch (code)
1038     {
1039     case VAR_DECL:
1040     case PARM_DECL:
1041     case RESULT_DECL:
1042       /* No action is needed in this case.  */
1043       return ref;
1044
1045     case NOP_EXPR:
1046     case CONVERT_EXPR:
1047     case FLOAT_EXPR:
1048     case FIX_TRUNC_EXPR:
1049     case FIX_FLOOR_EXPR:
1050     case FIX_ROUND_EXPR:
1051     case FIX_CEIL_EXPR:
1052       result = build_nt (code, stabilize_reference (TREE_OPERAND (ref, 0)));
1053       break;
1054
1055     case INDIRECT_REF:
1056       result = build_nt (INDIRECT_REF,
1057                          stabilize_reference_1 (TREE_OPERAND (ref, 0)));
1058       break;
1059
1060     case COMPONENT_REF:
1061       result = build_nt (COMPONENT_REF,
1062                          stabilize_reference (TREE_OPERAND (ref, 0)),
1063                          TREE_OPERAND (ref, 1));
1064       break;
1065
1066     case BIT_FIELD_REF:
1067       result = build_nt (BIT_FIELD_REF,
1068                          stabilize_reference (TREE_OPERAND (ref, 0)),
1069                          stabilize_reference_1 (TREE_OPERAND (ref, 1)),
1070                          stabilize_reference_1 (TREE_OPERAND (ref, 2)));
1071       break;
1072
1073     case ARRAY_REF:
1074       result = build_nt (ARRAY_REF,
1075                          stabilize_reference (TREE_OPERAND (ref, 0)),
1076                          stabilize_reference_1 (TREE_OPERAND (ref, 1)));
1077       break;
1078
1079     case COMPOUND_EXPR:
1080       result = build_nt (COMPOUND_EXPR,
1081                          stabilize_reference_1 (TREE_OPERAND (ref, 0)),
1082                          stabilize_reference (TREE_OPERAND (ref, 1)));
1083       break;
1084
1085     case RTL_EXPR:
1086       result = build1 (INDIRECT_REF, TREE_TYPE (ref),
1087                        save_expr (build1 (ADDR_EXPR,
1088                                           build_pointer_type (TREE_TYPE (ref)),
1089                                           ref)));
1090       break;
1091
1092
1093     default:
1094       return save_expr (ref);
1095
1096     case ERROR_MARK:
1097       return error_mark_node;
1098     }
1099
1100   TREE_TYPE (result) = TREE_TYPE (ref);
1101   TREE_READONLY (result) = TREE_READONLY (ref);
1102   TREE_SIDE_EFFECTS (result) = TREE_SIDE_EFFECTS (ref);
1103   TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
1104   TREE_RAISES (result) = TREE_RAISES (ref);
1105
1106   return result;
1107 }
1108 #endif
1109
1110 /* A rip-off of gcc's convert.c convert_to_complex function,
1111    reworked to handle complex implemented as C structures
1112    (RECORD_TYPE with two fields, real and imaginary `r' and `i').  */
1113
1114 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1115 static tree
1116 ffecom_convert_to_complex_ (tree type, tree expr)
1117 {
1118   register enum tree_code form = TREE_CODE (TREE_TYPE (expr));
1119   tree subtype;
1120
1121   assert (TREE_CODE (type) == RECORD_TYPE);
1122
1123   subtype = TREE_TYPE (TYPE_FIELDS (type));
1124
1125   if (form == REAL_TYPE || form == INTEGER_TYPE || form == ENUMERAL_TYPE)
1126     {
1127       expr = convert (subtype, expr);
1128       return ffecom_2 (COMPLEX_EXPR, type, expr,
1129                        convert (subtype, integer_zero_node));
1130     }
1131
1132   if (form == RECORD_TYPE)
1133     {
1134       tree elt_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr)));
1135       if (TYPE_MAIN_VARIANT (elt_type) == TYPE_MAIN_VARIANT (subtype))
1136         return expr;
1137       else
1138         {
1139           expr = save_expr (expr);
1140           return ffecom_2 (COMPLEX_EXPR,
1141                            type,
1142                            convert (subtype,
1143                                     ffecom_1 (REALPART_EXPR,
1144                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1145                                               expr)),
1146                            convert (subtype,
1147                                     ffecom_1 (IMAGPART_EXPR,
1148                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1149                                               expr)));
1150         }
1151     }
1152
1153   if (form == POINTER_TYPE || form == REFERENCE_TYPE)
1154     error ("pointer value used where a complex was expected");
1155   else
1156     error ("aggregate value used where a complex was expected");
1157
1158   return ffecom_2 (COMPLEX_EXPR, type,
1159                    convert (subtype, integer_zero_node),
1160                    convert (subtype, integer_zero_node));
1161 }
1162 #endif
1163
1164 /* Like gcc's convert(), but crashes if widening might happen.  */
1165
1166 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1167 static tree
1168 ffecom_convert_narrow_ (type, expr)
1169      tree type, expr;
1170 {
1171   register tree e = expr;
1172   register enum tree_code code = TREE_CODE (type);
1173
1174   if (type == TREE_TYPE (e)
1175       || TREE_CODE (e) == ERROR_MARK)
1176     return e;
1177   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1178     return fold (build1 (NOP_EXPR, type, e));
1179   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1180       || code == ERROR_MARK)
1181     return error_mark_node;
1182   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1183     {
1184       assert ("void value not ignored as it ought to be" == NULL);
1185       return error_mark_node;
1186     }
1187   assert (code != VOID_TYPE);
1188   if ((code != RECORD_TYPE)
1189       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1190     assert ("converting COMPLEX to REAL" == NULL);
1191   assert (code != ENUMERAL_TYPE);
1192   if (code == INTEGER_TYPE)
1193     {
1194       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1195                && TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)))
1196               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1197                   && (TYPE_PRECISION (type)
1198                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1199       return fold (convert_to_integer (type, e));
1200     }
1201   if (code == POINTER_TYPE)
1202     {
1203       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1204       return fold (convert_to_pointer (type, e));
1205     }
1206   if (code == REAL_TYPE)
1207     {
1208       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1209       assert (TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)));
1210       return fold (convert_to_real (type, e));
1211     }
1212   if (code == COMPLEX_TYPE)
1213     {
1214       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1215       assert (TYPE_PRECISION (TREE_TYPE (type)) <= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1216       return fold (convert_to_complex (type, e));
1217     }
1218   if (code == RECORD_TYPE)
1219     {
1220       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1221       /* Check that at least the first field name agrees.  */
1222       assert (DECL_NAME (TYPE_FIELDS (type))
1223               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1224       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1225               <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1226       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1227           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1228         return e;
1229       return fold (ffecom_convert_to_complex_ (type, e));
1230     }
1231
1232   assert ("conversion to non-scalar type requested" == NULL);
1233   return error_mark_node;
1234 }
1235 #endif
1236
1237 /* Like gcc's convert(), but crashes if narrowing might happen.  */
1238
1239 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1240 static tree
1241 ffecom_convert_widen_ (type, expr)
1242      tree type, expr;
1243 {
1244   register tree e = expr;
1245   register enum tree_code code = TREE_CODE (type);
1246
1247   if (type == TREE_TYPE (e)
1248       || TREE_CODE (e) == ERROR_MARK)
1249     return e;
1250   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1251     return fold (build1 (NOP_EXPR, type, e));
1252   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1253       || code == ERROR_MARK)
1254     return error_mark_node;
1255   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1256     {
1257       assert ("void value not ignored as it ought to be" == NULL);
1258       return error_mark_node;
1259     }
1260   assert (code != VOID_TYPE);
1261   if ((code != RECORD_TYPE)
1262       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1263     assert ("narrowing COMPLEX to REAL" == NULL);
1264   assert (code != ENUMERAL_TYPE);
1265   if (code == INTEGER_TYPE)
1266     {
1267       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1268                && TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)))
1269               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1270                   && (TYPE_PRECISION (type)
1271                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1272       return fold (convert_to_integer (type, e));
1273     }
1274   if (code == POINTER_TYPE)
1275     {
1276       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1277       return fold (convert_to_pointer (type, e));
1278     }
1279   if (code == REAL_TYPE)
1280     {
1281       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1282       assert (TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)));
1283       return fold (convert_to_real (type, e));
1284     }
1285   if (code == COMPLEX_TYPE)
1286     {
1287       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1288       assert (TYPE_PRECISION (TREE_TYPE (type)) >= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1289       return fold (convert_to_complex (type, e));
1290     }
1291   if (code == RECORD_TYPE)
1292     {
1293       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1294       /* Check that at least the first field name agrees.  */
1295       assert (DECL_NAME (TYPE_FIELDS (type))
1296               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1297       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1298               >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1299       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1300           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1301         return e;
1302       return fold (ffecom_convert_to_complex_ (type, e));
1303     }
1304
1305   assert ("conversion to non-scalar type requested" == NULL);
1306   return error_mark_node;
1307 }
1308 #endif
1309
1310 /* Handles making a COMPLEX type, either the standard
1311    (but buggy?) gbe way, or the safer (but less elegant?)
1312    f2c way.  */
1313
1314 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1315 static tree
1316 ffecom_make_complex_type_ (tree subtype)
1317 {
1318   tree type;
1319   tree realfield;
1320   tree imagfield;
1321
1322   if (ffe_is_emulate_complex ())
1323     {
1324       type = make_node (RECORD_TYPE);
1325       realfield = ffecom_decl_field (type, NULL_TREE, "r", subtype);
1326       imagfield = ffecom_decl_field (type, realfield, "i", subtype);
1327       TYPE_FIELDS (type) = realfield;
1328       layout_type (type);
1329     }
1330   else
1331     {
1332       type = make_node (COMPLEX_TYPE);
1333       TREE_TYPE (type) = subtype;
1334       layout_type (type);
1335     }
1336
1337   return type;
1338 }
1339 #endif
1340
1341 /* Chooses either the gbe or the f2c way to build a
1342    complex constant.  */
1343
1344 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1345 static tree
1346 ffecom_build_complex_constant_ (tree type, tree realpart, tree imagpart)
1347 {
1348   tree bothparts;
1349
1350   if (ffe_is_emulate_complex ())
1351     {
1352       bothparts = build_tree_list (TYPE_FIELDS (type), realpart);
1353       TREE_CHAIN (bothparts) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), imagpart);
1354       bothparts = build (CONSTRUCTOR, type, NULL_TREE, bothparts);
1355     }
1356   else
1357     {
1358       bothparts = build_complex (type, realpart, imagpart);
1359     }
1360
1361   return bothparts;
1362 }
1363 #endif
1364
1365 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1366 static tree
1367 ffecom_arglist_expr_ (const char *c, ffebld expr)
1368 {
1369   tree list;
1370   tree *plist = &list;
1371   tree trail = NULL_TREE;       /* Append char length args here. */
1372   tree *ptrail = &trail;
1373   tree length;
1374   ffebld exprh;
1375   tree item;
1376   bool ptr = FALSE;
1377   tree wanted = NULL_TREE;
1378   static char zed[] = "0";
1379
1380   if (c == NULL)
1381     c = &zed[0];
1382
1383   while (expr != NULL)
1384     {
1385       if (*c != '\0')
1386         {
1387           ptr = FALSE;
1388           if (*c == '&')
1389             {
1390               ptr = TRUE;
1391               ++c;
1392             }
1393           switch (*(c++))
1394             {
1395             case '\0':
1396               ptr = TRUE;
1397               wanted = NULL_TREE;
1398               break;
1399
1400             case 'a':
1401               assert (ptr);
1402               wanted = NULL_TREE;
1403               break;
1404
1405             case 'c':
1406               wanted = ffecom_f2c_complex_type_node;
1407               break;
1408
1409             case 'd':
1410               wanted = ffecom_f2c_doublereal_type_node;
1411               break;
1412
1413             case 'e':
1414               wanted = ffecom_f2c_doublecomplex_type_node;
1415               break;
1416
1417             case 'f':
1418               wanted = ffecom_f2c_real_type_node;
1419               break;
1420
1421             case 'i':
1422               wanted = ffecom_f2c_integer_type_node;
1423               break;
1424
1425             case 'j':
1426               wanted = ffecom_f2c_longint_type_node;
1427               break;
1428
1429             default:
1430               assert ("bad argstring code" == NULL);
1431               wanted = NULL_TREE;
1432               break;
1433             }
1434         }
1435
1436       exprh = ffebld_head (expr);
1437       if (exprh == NULL)
1438         wanted = NULL_TREE;
1439
1440       if ((wanted == NULL_TREE)
1441           || (ptr
1442               && (TYPE_MODE
1443                   (ffecom_tree_type[ffeinfo_basictype (ffebld_info (exprh))]
1444                    [ffeinfo_kindtype (ffebld_info (exprh))])
1445                    == TYPE_MODE (wanted))))
1446         *plist
1447           = build_tree_list (NULL_TREE,
1448                              ffecom_arg_ptr_to_expr (exprh,
1449                                                      &length));
1450       else
1451         {
1452           item = ffecom_arg_expr (exprh, &length);
1453           item = ffecom_convert_widen_ (wanted, item);
1454           if (ptr)
1455             {
1456               item = ffecom_1 (ADDR_EXPR,
1457                                build_pointer_type (TREE_TYPE (item)),
1458                                item);
1459             }
1460           *plist
1461             = build_tree_list (NULL_TREE,
1462                                item);
1463         }
1464
1465       plist = &TREE_CHAIN (*plist);
1466       expr = ffebld_trail (expr);
1467       if (length != NULL_TREE)
1468         {
1469           *ptrail = build_tree_list (NULL_TREE, length);
1470           ptrail = &TREE_CHAIN (*ptrail);
1471         }
1472     }
1473
1474   /* We've run out of args in the call; if the implementation expects
1475      more, supply null pointers for them, which the implementation can
1476      check to see if an arg was omitted. */
1477
1478   while (*c != '\0' && *c != '0')
1479     {
1480       if (*c == '&')
1481         ++c;
1482       else
1483         assert ("missing arg to run-time routine!" == NULL);
1484
1485       switch (*(c++))
1486         {
1487         case '\0':
1488         case 'a':
1489         case 'c':
1490         case 'd':
1491         case 'e':
1492         case 'f':
1493         case 'i':
1494         case 'j':
1495           break;
1496
1497         default:
1498           assert ("bad arg string code" == NULL);
1499           break;
1500         }
1501       *plist
1502         = build_tree_list (NULL_TREE,
1503                            null_pointer_node);
1504       plist = &TREE_CHAIN (*plist);
1505     }
1506
1507   *plist = trail;
1508
1509   return list;
1510 }
1511 #endif
1512
1513 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1514 static tree
1515 ffecom_widest_expr_type_ (ffebld list)
1516 {
1517   ffebld item;
1518   ffebld widest = NULL;
1519   ffetype type;
1520   ffetype widest_type = NULL;
1521   tree t;
1522
1523   for (; list != NULL; list = ffebld_trail (list))
1524     {
1525       item = ffebld_head (list);
1526       if (item == NULL)
1527         continue;
1528       if ((widest != NULL)
1529           && (ffeinfo_basictype (ffebld_info (item))
1530               != ffeinfo_basictype (ffebld_info (widest))))
1531         continue;
1532       type = ffeinfo_type (ffeinfo_basictype (ffebld_info (item)),
1533                            ffeinfo_kindtype (ffebld_info (item)));
1534       if ((widest == FFEINFO_kindtypeNONE)
1535           || (ffetype_size (type)
1536               > ffetype_size (widest_type)))
1537         {
1538           widest = item;
1539           widest_type = type;
1540         }
1541     }
1542
1543   assert (widest != NULL);
1544   t = ffecom_tree_type[ffeinfo_basictype (ffebld_info (widest))]
1545     [ffeinfo_kindtype (ffebld_info (widest))];
1546   assert (t != NULL_TREE);
1547   return t;
1548 }
1549 #endif
1550
1551 /* Check whether a partial overlap between two expressions is possible.
1552
1553    Can *starting* to write a portion of expr1 change the value
1554    computed (perhaps already, *partially*) by expr2?
1555
1556    Currently, this is a concern only for a COMPLEX expr1.  But if it
1557    isn't in COMMON or local EQUIVALENCE, since we don't support
1558    aliasing of arguments, it isn't a concern.  */
1559
1560 static bool
1561 ffecom_possible_partial_overlap_ (ffebld expr1, ffebld expr2 ATTRIBUTE_UNUSED)
1562 {
1563   ffesymbol sym;
1564   ffestorag st;
1565
1566   switch (ffebld_op (expr1))
1567     {
1568     case FFEBLD_opSYMTER:
1569       sym = ffebld_symter (expr1);
1570       break;
1571
1572     case FFEBLD_opARRAYREF:
1573       if (ffebld_op (ffebld_left (expr1)) != FFEBLD_opSYMTER)
1574         return FALSE;
1575       sym = ffebld_symter (ffebld_left (expr1));
1576       break;
1577
1578     default:
1579       return FALSE;
1580     }
1581
1582   if (ffesymbol_where (sym) != FFEINFO_whereCOMMON
1583       && (ffesymbol_where (sym) != FFEINFO_whereLOCAL
1584           || ! (st = ffesymbol_storage (sym))
1585           || ! ffestorag_parent (st)))
1586     return FALSE;
1587
1588   /* It's in COMMON or local EQUIVALENCE.  */
1589
1590   return TRUE;
1591 }
1592
1593 /* Check whether dest and source might overlap.  ffebld versions of these
1594    might or might not be passed, will be NULL if not.
1595
1596    The test is really whether source_tree is modifiable and, if modified,
1597    might overlap destination such that the value(s) in the destination might
1598    change before it is finally modified.  dest_* are the canonized
1599    destination itself.  */
1600
1601 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1602 static bool
1603 ffecom_overlap_ (tree dest_decl, tree dest_offset, tree dest_size,
1604                  tree source_tree, ffebld source UNUSED,
1605                  bool scalar_arg)
1606 {
1607   tree source_decl;
1608   tree source_offset;
1609   tree source_size;
1610   tree t;
1611
1612   if (source_tree == NULL_TREE)
1613     return FALSE;
1614
1615   switch (TREE_CODE (source_tree))
1616     {
1617     case ERROR_MARK:
1618     case IDENTIFIER_NODE:
1619     case INTEGER_CST:
1620     case REAL_CST:
1621     case COMPLEX_CST:
1622     case STRING_CST:
1623     case CONST_DECL:
1624     case VAR_DECL:
1625     case RESULT_DECL:
1626     case FIELD_DECL:
1627     case MINUS_EXPR:
1628     case MULT_EXPR:
1629     case TRUNC_DIV_EXPR:
1630     case CEIL_DIV_EXPR:
1631     case FLOOR_DIV_EXPR:
1632     case ROUND_DIV_EXPR:
1633     case TRUNC_MOD_EXPR:
1634     case CEIL_MOD_EXPR:
1635     case FLOOR_MOD_EXPR:
1636     case ROUND_MOD_EXPR:
1637     case RDIV_EXPR:
1638     case EXACT_DIV_EXPR:
1639     case FIX_TRUNC_EXPR:
1640     case FIX_CEIL_EXPR:
1641     case FIX_FLOOR_EXPR:
1642     case FIX_ROUND_EXPR:
1643     case FLOAT_EXPR:
1644     case EXPON_EXPR:
1645     case NEGATE_EXPR:
1646     case MIN_EXPR:
1647     case MAX_EXPR:
1648     case ABS_EXPR:
1649     case FFS_EXPR:
1650     case LSHIFT_EXPR:
1651     case RSHIFT_EXPR:
1652     case LROTATE_EXPR:
1653     case RROTATE_EXPR:
1654     case BIT_IOR_EXPR:
1655     case BIT_XOR_EXPR:
1656     case BIT_AND_EXPR:
1657     case BIT_ANDTC_EXPR:
1658     case BIT_NOT_EXPR:
1659     case TRUTH_ANDIF_EXPR:
1660     case TRUTH_ORIF_EXPR:
1661     case TRUTH_AND_EXPR:
1662     case TRUTH_OR_EXPR:
1663     case TRUTH_XOR_EXPR:
1664     case TRUTH_NOT_EXPR:
1665     case LT_EXPR:
1666     case LE_EXPR:
1667     case GT_EXPR:
1668     case GE_EXPR:
1669     case EQ_EXPR:
1670     case NE_EXPR:
1671     case COMPLEX_EXPR:
1672     case CONJ_EXPR:
1673     case REALPART_EXPR:
1674     case IMAGPART_EXPR:
1675     case LABEL_EXPR:
1676     case COMPONENT_REF:
1677       return FALSE;
1678
1679     case COMPOUND_EXPR:
1680       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1681                               TREE_OPERAND (source_tree, 1), NULL,
1682                               scalar_arg);
1683
1684     case MODIFY_EXPR:
1685       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1686                               TREE_OPERAND (source_tree, 0), NULL,
1687                               scalar_arg);
1688
1689     case CONVERT_EXPR:
1690     case NOP_EXPR:
1691     case NON_LVALUE_EXPR:
1692     case PLUS_EXPR:
1693       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1694         return TRUE;
1695
1696       ffecom_tree_canonize_ptr_ (&source_decl, &source_offset,
1697                                  source_tree);
1698       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1699       break;
1700
1701     case COND_EXPR:
1702       return
1703         ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1704                          TREE_OPERAND (source_tree, 1), NULL,
1705                          scalar_arg)
1706           || ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1707                               TREE_OPERAND (source_tree, 2), NULL,
1708                               scalar_arg);
1709
1710
1711     case ADDR_EXPR:
1712       ffecom_tree_canonize_ref_ (&source_decl, &source_offset,
1713                                  &source_size,
1714                                  TREE_OPERAND (source_tree, 0));
1715       break;
1716
1717     case PARM_DECL:
1718       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1719         return TRUE;
1720
1721       source_decl = source_tree;
1722       source_offset = size_zero_node;
1723       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1724       break;
1725
1726     case SAVE_EXPR:
1727     case REFERENCE_EXPR:
1728     case PREDECREMENT_EXPR:
1729     case PREINCREMENT_EXPR:
1730     case POSTDECREMENT_EXPR:
1731     case POSTINCREMENT_EXPR:
1732     case INDIRECT_REF:
1733     case ARRAY_REF:
1734     case CALL_EXPR:
1735     default:
1736       return TRUE;
1737     }
1738
1739   /* Come here when source_decl, source_offset, and source_size filled
1740      in appropriately.  */
1741
1742   if (source_decl == NULL_TREE)
1743     return FALSE;               /* No decl involved, so no overlap. */
1744
1745   if (source_decl != dest_decl)
1746     return FALSE;               /* Different decl, no overlap. */
1747
1748   if (TREE_CODE (dest_size) == ERROR_MARK)
1749     return TRUE;                /* Assignment into entire assumed-size
1750                                    array?  Shouldn't happen.... */
1751
1752   t = ffecom_2 (LE_EXPR, integer_type_node,
1753                 ffecom_2 (PLUS_EXPR, TREE_TYPE (dest_offset),
1754                           dest_offset,
1755                           convert (TREE_TYPE (dest_offset),
1756                                    dest_size)),
1757                 convert (TREE_TYPE (dest_offset),
1758                          source_offset));
1759
1760   if (integer_onep (t))
1761     return FALSE;               /* Destination precedes source. */
1762
1763   if (!scalar_arg
1764       || (source_size == NULL_TREE)
1765       || (TREE_CODE (source_size) == ERROR_MARK)
1766       || integer_zerop (source_size))
1767     return TRUE;                /* No way to tell if dest follows source. */
1768
1769   t = ffecom_2 (LE_EXPR, integer_type_node,
1770                 ffecom_2 (PLUS_EXPR, TREE_TYPE (source_offset),
1771                           source_offset,
1772                           convert (TREE_TYPE (source_offset),
1773                                    source_size)),
1774                 convert (TREE_TYPE (source_offset),
1775                          dest_offset));
1776
1777   if (integer_onep (t))
1778     return FALSE;               /* Destination follows source. */
1779
1780   return TRUE;          /* Destination and source overlap. */
1781 }
1782 #endif
1783
1784 /* Check whether dest might overlap any of a list of arguments or is
1785    in a COMMON area the callee might know about (and thus modify).  */
1786
1787 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1788 static bool
1789 ffecom_args_overlapping_ (tree dest_tree, ffebld dest UNUSED,
1790                           tree args, tree callee_commons,
1791                           bool scalar_args)
1792 {
1793   tree arg;
1794   tree dest_decl;
1795   tree dest_offset;
1796   tree dest_size;
1797
1798   ffecom_tree_canonize_ref_ (&dest_decl, &dest_offset, &dest_size,
1799                              dest_tree);
1800
1801   if (dest_decl == NULL_TREE)
1802     return FALSE;               /* Seems unlikely! */
1803
1804   /* If the decl cannot be determined reliably, or if its in COMMON
1805      and the callee isn't known to not futz with COMMON via other
1806      means, overlap might happen.  */
1807
1808   if ((TREE_CODE (dest_decl) == ERROR_MARK)
1809       || ((callee_commons != NULL_TREE)
1810           && TREE_PUBLIC (dest_decl)))
1811     return TRUE;
1812
1813   for (; args != NULL_TREE; args = TREE_CHAIN (args))
1814     {
1815       if (((arg = TREE_VALUE (args)) != NULL_TREE)
1816           && ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1817                               arg, NULL, scalar_args))
1818         return TRUE;
1819     }
1820
1821   return FALSE;
1822 }
1823 #endif
1824
1825 /* Build a string for a variable name as used by NAMELIST.  This means that
1826    if we're using the f2c library, we build an uppercase string, since
1827    f2c does this.  */
1828
1829 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1830 static tree
1831 ffecom_build_f2c_string_ (int i, const char *s)
1832 {
1833   if (!ffe_is_f2c_library ())
1834     return build_string (i, s);
1835
1836   {
1837     char *tmp;
1838     const char *p;
1839     char *q;
1840     char space[34];
1841     tree t;
1842
1843     if (((size_t) i) > ARRAY_SIZE (space))
1844       tmp = malloc_new_ks (malloc_pool_image (), "f2c_string", i);
1845     else
1846       tmp = &space[0];
1847
1848     for (p = s, q = tmp; *p != '\0'; ++p, ++q)
1849       *q = ffesrc_toupper (*p);
1850     *q = '\0';
1851
1852     t = build_string (i, tmp);
1853
1854     if (((size_t) i) > ARRAY_SIZE (space))
1855       malloc_kill_ks (malloc_pool_image (), tmp, i);
1856
1857     return t;
1858   }
1859 }
1860
1861 #endif
1862 /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
1863    type to just get whatever the function returns), handling the
1864    f2c value-returning convention, if required, by prepending
1865    to the arglist a pointer to a temporary to receive the return value.  */
1866
1867 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1868 static tree
1869 ffecom_call_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1870               tree type, tree args, tree dest_tree,
1871               ffebld dest, bool *dest_used, tree callee_commons,
1872               bool scalar_args, tree hook)
1873 {
1874   tree item;
1875   tree tempvar;
1876
1877   if (dest_used != NULL)
1878     *dest_used = FALSE;
1879
1880   if (is_f2c_complex)
1881     {
1882       if ((dest_used == NULL)
1883           || (dest == NULL)
1884           || (ffeinfo_basictype (ffebld_info (dest))
1885               != FFEINFO_basictypeCOMPLEX)
1886           || (ffeinfo_kindtype (ffebld_info (dest)) != kt)
1887           || ((type != NULL_TREE) && (TREE_TYPE (dest_tree) != type))
1888           || ffecom_args_overlapping_ (dest_tree, dest, args,
1889                                        callee_commons,
1890                                        scalar_args))
1891         {
1892 #ifdef HOHO
1893           tempvar = ffecom_make_tempvar (ffecom_tree_type
1894                                          [FFEINFO_basictypeCOMPLEX][kt],
1895                                          FFETARGET_charactersizeNONE,
1896                                          -1);
1897 #else
1898           tempvar = hook;
1899           assert (tempvar);
1900 #endif
1901         }
1902       else
1903         {
1904           *dest_used = TRUE;
1905           tempvar = dest_tree;
1906           type = NULL_TREE;
1907         }
1908
1909       item
1910         = build_tree_list (NULL_TREE,
1911                            ffecom_1 (ADDR_EXPR,
1912                                      build_pointer_type (TREE_TYPE (tempvar)),
1913                                      tempvar));
1914       TREE_CHAIN (item) = args;
1915
1916       item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1917                         item, NULL_TREE);
1918
1919       if (tempvar != dest_tree)
1920         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item, tempvar);
1921     }
1922   else
1923     item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1924                       args, NULL_TREE);
1925
1926   if ((type != NULL_TREE) && (TREE_TYPE (item) != type))
1927     item = ffecom_convert_narrow_ (type, item);
1928
1929   return item;
1930 }
1931 #endif
1932
1933 /* Given two arguments, transform them and make a call to the given
1934    function via ffecom_call_.  */
1935
1936 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1937 static tree
1938 ffecom_call_binop_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1939                     tree type, ffebld left, ffebld right,
1940                     tree dest_tree, ffebld dest, bool *dest_used,
1941                     tree callee_commons, bool scalar_args, tree hook)
1942 {
1943   tree left_tree;
1944   tree right_tree;
1945   tree left_length;
1946   tree right_length;
1947
1948   left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
1949   right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
1950
1951   left_tree = build_tree_list (NULL_TREE, left_tree);
1952   right_tree = build_tree_list (NULL_TREE, right_tree);
1953   TREE_CHAIN (left_tree) = right_tree;
1954
1955   if (left_length != NULL_TREE)
1956     {
1957       left_length = build_tree_list (NULL_TREE, left_length);
1958       TREE_CHAIN (right_tree) = left_length;
1959     }
1960
1961   if (right_length != NULL_TREE)
1962     {
1963       right_length = build_tree_list (NULL_TREE, right_length);
1964       if (left_length != NULL_TREE)
1965         TREE_CHAIN (left_length) = right_length;
1966       else
1967         TREE_CHAIN (right_tree) = right_length;
1968     }
1969
1970   return ffecom_call_ (fn, kt, is_f2c_complex, type, left_tree,
1971                        dest_tree, dest, dest_used, callee_commons,
1972                        scalar_args, hook);
1973 }
1974 #endif
1975
1976 /* Return ptr/length args for char subexpression
1977
1978    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
1979    subexpressions by constructing the appropriate trees for the ptr-to-
1980    character-text and length-of-character-text arguments in a calling
1981    sequence.
1982
1983    Note that if with_null is TRUE, and the expression is an opCONTER,
1984    a null byte is appended to the string.  */
1985
1986 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1987 static void
1988 ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null)
1989 {
1990   tree item;
1991   tree high;
1992   ffetargetCharacter1 val;
1993   ffetargetCharacterSize newlen;
1994
1995   switch (ffebld_op (expr))
1996     {
1997     case FFEBLD_opCONTER:
1998       val = ffebld_constant_character1 (ffebld_conter (expr));
1999       newlen = ffetarget_length_character1 (val);
2000       if (with_null)
2001         {
2002           /* Begin FFETARGET-NULL-KLUDGE.  */
2003           if (newlen != 0)
2004             ++newlen;
2005         }
2006       *length = build_int_2 (newlen, 0);
2007       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2008       high = build_int_2 (newlen, 0);
2009       TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
2010       item = build_string (newlen,
2011                            ffetarget_text_character1 (val));
2012       /* End FFETARGET-NULL-KLUDGE.  */
2013       TREE_TYPE (item)
2014         = build_type_variant
2015           (build_array_type
2016            (char_type_node,
2017             build_range_type
2018             (ffecom_f2c_ftnlen_type_node,
2019              ffecom_f2c_ftnlen_one_node,
2020              high)),
2021            1, 0);
2022       TREE_CONSTANT (item) = 1;
2023       TREE_STATIC (item) = 1;
2024       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
2025                        item);
2026       break;
2027
2028     case FFEBLD_opSYMTER:
2029       {
2030         ffesymbol s = ffebld_symter (expr);
2031
2032         item = ffesymbol_hook (s).decl_tree;
2033         if (item == NULL_TREE)
2034           {
2035             s = ffecom_sym_transform_ (s);
2036             item = ffesymbol_hook (s).decl_tree;
2037           }
2038         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
2039           {
2040             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
2041               *length = ffesymbol_hook (s).length_tree;
2042             else
2043               {
2044                 *length = build_int_2 (ffesymbol_size (s), 0);
2045                 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2046               }
2047           }
2048         else if (item == error_mark_node)
2049           *length = error_mark_node;
2050         else
2051           /* FFEINFO_kindFUNCTION.  */
2052           *length = NULL_TREE;
2053         if (!ffesymbol_hook (s).addr
2054             && (item != error_mark_node))
2055           item = ffecom_1 (ADDR_EXPR,
2056                            build_pointer_type (TREE_TYPE (item)),
2057                            item);
2058       }
2059       break;
2060
2061     case FFEBLD_opARRAYREF:
2062       {
2063         ffecom_char_args_ (&item, length, ffebld_left (expr));
2064
2065         if (item == error_mark_node || *length == error_mark_node)
2066           {
2067             item = *length = error_mark_node;
2068             break;
2069           }
2070
2071         item = ffecom_arrayref_ (item, expr, 1);
2072       }
2073       break;
2074
2075     case FFEBLD_opSUBSTR:
2076       {
2077         ffebld start;
2078         ffebld end;
2079         ffebld thing = ffebld_right (expr);
2080         tree start_tree;
2081         tree end_tree;
2082         char *char_name;
2083         ffebld left_symter;
2084         tree array;
2085
2086         assert (ffebld_op (thing) == FFEBLD_opITEM);
2087         start = ffebld_head (thing);
2088         thing = ffebld_trail (thing);
2089         assert (ffebld_trail (thing) == NULL);
2090         end = ffebld_head (thing);
2091
2092         /* Determine name for pretty-printing range-check errors.  */
2093         for (left_symter = ffebld_left (expr);
2094              left_symter && ffebld_op (left_symter) == FFEBLD_opARRAYREF;
2095              left_symter = ffebld_left (left_symter))
2096           ;
2097         if (ffebld_op (left_symter) == FFEBLD_opSYMTER)
2098           char_name = ffesymbol_text (ffebld_symter (left_symter));
2099         else
2100           char_name = "[expr?]";
2101
2102         ffecom_char_args_ (&item, length, ffebld_left (expr));
2103
2104         if (item == error_mark_node || *length == error_mark_node)
2105           {
2106             item = *length = error_mark_node;
2107             break;
2108           }
2109
2110         array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
2111
2112         /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF.  */
2113
2114         if (start == NULL)
2115           {
2116             if (end == NULL)
2117               ;
2118             else
2119               {
2120                 end_tree = ffecom_expr (end);
2121                 if (flag_bounds_check)
2122                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2123                                                       char_name);
2124                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2125                                     end_tree);
2126
2127                 if (end_tree == error_mark_node)
2128                   {
2129                     item = *length = error_mark_node;
2130                     break;
2131                   }
2132
2133                 *length = end_tree;
2134               }
2135           }
2136         else
2137           {
2138             start_tree = ffecom_expr (start);
2139             if (flag_bounds_check)
2140               start_tree = ffecom_subscript_check_ (array, start_tree, 0, 0,
2141                                                     char_name);
2142             start_tree = convert (ffecom_f2c_ftnlen_type_node,
2143                                   start_tree);
2144
2145             if (start_tree == error_mark_node)
2146               {
2147                 item = *length = error_mark_node;
2148                 break;
2149               }
2150
2151             start_tree = ffecom_save_tree (start_tree);
2152
2153             item = ffecom_2 (PLUS_EXPR, TREE_TYPE (item),
2154                              item,
2155                              ffecom_2 (MINUS_EXPR,
2156                                        TREE_TYPE (start_tree),
2157                                        start_tree,
2158                                        ffecom_f2c_ftnlen_one_node));
2159
2160             if (end == NULL)
2161               {
2162                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2163                                     ffecom_f2c_ftnlen_one_node,
2164                                     ffecom_2 (MINUS_EXPR,
2165                                               ffecom_f2c_ftnlen_type_node,
2166                                               *length,
2167                                               start_tree));
2168               }
2169             else
2170               {
2171                 end_tree = ffecom_expr (end);
2172                 if (flag_bounds_check)
2173                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2174                                                       char_name);
2175                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2176                                     end_tree);
2177
2178                 if (end_tree == error_mark_node)
2179                   {
2180                     item = *length = error_mark_node;
2181                     break;
2182                   }
2183
2184                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2185                                     ffecom_f2c_ftnlen_one_node,
2186                                     ffecom_2 (MINUS_EXPR,
2187                                               ffecom_f2c_ftnlen_type_node,
2188                                               end_tree, start_tree));
2189               }
2190           }
2191       }
2192       break;
2193
2194     case FFEBLD_opFUNCREF:
2195       {
2196         ffesymbol s = ffebld_symter (ffebld_left (expr));
2197         tree tempvar;
2198         tree args;
2199         ffetargetCharacterSize size = ffeinfo_size (ffebld_info (expr));
2200         ffecomGfrt ix;
2201
2202         if (size == FFETARGET_charactersizeNONE)
2203           /* ~~Kludge alert!  This should someday be fixed. */
2204           size = 24;
2205
2206         *length = build_int_2 (size, 0);
2207         TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2208
2209         if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
2210             == FFEINFO_whereINTRINSIC)
2211           {
2212             if (size == 1)
2213               {
2214                 /* Invocation of an intrinsic returning CHARACTER*1.  */
2215                 item = ffecom_expr_intrinsic_ (expr, NULL_TREE,
2216                                                NULL, NULL);
2217                 break;
2218               }
2219             ix = ffeintrin_gfrt_direct (ffebld_symter_implementation (ffebld_left (expr)));
2220             assert (ix != FFECOM_gfrt);
2221             item = ffecom_gfrt_tree_ (ix);
2222           }
2223         else
2224           {
2225             ix = FFECOM_gfrt;
2226             item = ffesymbol_hook (s).decl_tree;
2227             if (item == NULL_TREE)
2228               {
2229                 s = ffecom_sym_transform_ (s);
2230                 item = ffesymbol_hook (s).decl_tree;
2231               }
2232             if (item == error_mark_node)
2233               {
2234                 item = *length = error_mark_node;
2235                 break;
2236               }
2237
2238             if (!ffesymbol_hook (s).addr)
2239               item = ffecom_1_fn (item);
2240           }
2241
2242 #ifdef HOHO
2243         tempvar = ffecom_push_tempvar (char_type_node, size, -1, TRUE);
2244 #else
2245         tempvar = ffebld_nonter_hook (expr);
2246         assert (tempvar);
2247 #endif
2248         tempvar = ffecom_1 (ADDR_EXPR,
2249                             build_pointer_type (TREE_TYPE (tempvar)),
2250                             tempvar);
2251
2252         args = build_tree_list (NULL_TREE, tempvar);
2253
2254         if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)       /* Sfunc args by value. */
2255           TREE_CHAIN (args) = ffecom_list_expr (ffebld_right (expr));
2256         else
2257           {
2258             TREE_CHAIN (args) = build_tree_list (NULL_TREE, *length);
2259             if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
2260               {
2261                 TREE_CHAIN (TREE_CHAIN (args))
2262                   = ffecom_arglist_expr_ (ffecom_gfrt_args_ (ix),
2263                                           ffebld_right (expr));
2264               }
2265             else
2266               {
2267                 TREE_CHAIN (TREE_CHAIN (args))
2268                   = ffecom_list_ptr_to_expr (ffebld_right (expr));
2269               }
2270           }
2271
2272         item = ffecom_3s (CALL_EXPR,
2273                           TREE_TYPE (TREE_TYPE (TREE_TYPE (item))),
2274                           item, args, NULL_TREE);
2275         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item,
2276                          tempvar);
2277       }
2278       break;
2279
2280     case FFEBLD_opCONVERT:
2281
2282       ffecom_char_args_ (&item, length, ffebld_left (expr));
2283
2284       if (item == error_mark_node || *length == error_mark_node)
2285         {
2286           item = *length = error_mark_node;
2287           break;
2288         }
2289
2290       if ((ffebld_size_known (ffebld_left (expr))
2291            == FFETARGET_charactersizeNONE)
2292           || (ffebld_size_known (ffebld_left (expr)) < (ffebld_size (expr))))
2293         {                       /* Possible blank-padding needed, copy into
2294                                    temporary. */
2295           tree tempvar;
2296           tree args;
2297           tree newlen;
2298
2299 #ifdef HOHO
2300           tempvar = ffecom_make_tempvar (char_type_node,
2301                                          ffebld_size (expr), -1);
2302 #else
2303           tempvar = ffebld_nonter_hook (expr);
2304           assert (tempvar);
2305 #endif
2306           tempvar = ffecom_1 (ADDR_EXPR,
2307                               build_pointer_type (TREE_TYPE (tempvar)),
2308                               tempvar);
2309
2310           newlen = build_int_2 (ffebld_size (expr), 0);
2311           TREE_TYPE (newlen) = ffecom_f2c_ftnlen_type_node;
2312
2313           args = build_tree_list (NULL_TREE, tempvar);
2314           TREE_CHAIN (args) = build_tree_list (NULL_TREE, item);
2315           TREE_CHAIN (TREE_CHAIN (args)) = build_tree_list (NULL_TREE, newlen);
2316           TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args)))
2317             = build_tree_list (NULL_TREE, *length);
2318
2319           item = ffecom_call_gfrt (FFECOM_gfrtCOPY, args, NULL_TREE);
2320           TREE_SIDE_EFFECTS (item) = 1;
2321           item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), fold (item),
2322                            tempvar);
2323           *length = newlen;
2324         }
2325       else
2326         {                       /* Just truncate the length. */
2327           *length = build_int_2 (ffebld_size (expr), 0);
2328           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2329         }
2330       break;
2331
2332     default:
2333       assert ("bad op for single char arg expr" == NULL);
2334       item = NULL_TREE;
2335       break;
2336     }
2337
2338   *xitem = item;
2339 }
2340 #endif
2341
2342 /* Check the size of the type to be sure it doesn't overflow the
2343    "portable" capacities of the compiler back end.  `dummy' types
2344    can generally overflow the normal sizes as long as the computations
2345    themselves don't overflow.  A particular target of the back end
2346    must still enforce its size requirements, though, and the back
2347    end takes care of this in stor-layout.c.  */
2348
2349 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2350 static tree
2351 ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy)
2352 {
2353   if (TREE_CODE (type) == ERROR_MARK)
2354     return type;
2355
2356   if (TYPE_SIZE (type) == NULL_TREE)
2357     return type;
2358
2359   if (TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST)
2360     return type;
2361
2362   if ((tree_int_cst_sgn (TYPE_SIZE (type)) < 0)
2363       || (!dummy && (((TREE_INT_CST_HIGH (TYPE_SIZE (type)) != 0))
2364                      || TREE_OVERFLOW (TYPE_SIZE (type)))))
2365     {
2366       ffebad_start (FFEBAD_ARRAY_LARGE);
2367       ffebad_string (ffesymbol_text (s));
2368       ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
2369       ffebad_finish ();
2370
2371       return error_mark_node;
2372     }
2373
2374   return type;
2375 }
2376 #endif
2377
2378 /* Builds a length argument (PARM_DECL).  Also wraps type in an array type
2379    where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
2380    known, length_arg if not known (FFETARGET_charactersizeNONE).  */
2381
2382 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2383 static tree
2384 ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s)
2385 {
2386   ffetargetCharacterSize sz = ffesymbol_size (s);
2387   tree highval;
2388   tree tlen;
2389   tree type = *xtype;
2390
2391   if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
2392     tlen = NULL_TREE;           /* A statement function, no length passed. */
2393   else
2394     {
2395       if (ffesymbol_where (s) == FFEINFO_whereDUMMY)
2396         tlen = ffecom_get_invented_identifier ("__g77_length_%s",
2397                                                ffesymbol_text (s));
2398       else
2399         tlen = ffecom_get_invented_identifier ("__g77_%s", "length");
2400       tlen = build_decl (PARM_DECL, tlen, ffecom_f2c_ftnlen_type_node);
2401 #if BUILT_FOR_270
2402       DECL_ARTIFICIAL (tlen) = 1;
2403 #endif
2404     }
2405
2406   if (sz == FFETARGET_charactersizeNONE)
2407     {
2408       assert (tlen != NULL_TREE);
2409       highval = variable_size (tlen);
2410     }
2411   else
2412     {
2413       highval = build_int_2 (sz, 0);
2414       TREE_TYPE (highval) = ffecom_f2c_ftnlen_type_node;
2415     }
2416
2417   type = build_array_type (type,
2418                            build_range_type (ffecom_f2c_ftnlen_type_node,
2419                                              ffecom_f2c_ftnlen_one_node,
2420                                              highval));
2421
2422   *xtype = type;
2423   return tlen;
2424 }
2425
2426 #endif
2427 /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
2428
2429    ffecomConcatList_ catlist;
2430    ffebld expr;  // expr of CHARACTER basictype.
2431    ffetargetCharacterSize max;  // max chars to gather or _...NONE if no max
2432    catlist = ffecom_concat_list_gather_(catlist,expr,max);
2433
2434    Scans expr for character subexpressions, updates and returns catlist
2435    accordingly.  */
2436
2437 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2438 static ffecomConcatList_
2439 ffecom_concat_list_gather_ (ffecomConcatList_ catlist, ffebld expr,
2440                             ffetargetCharacterSize max)
2441 {
2442   ffetargetCharacterSize sz;
2443
2444 recurse:                        /* :::::::::::::::::::: */
2445
2446   if (expr == NULL)
2447     return catlist;
2448
2449   if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen >= max))
2450     return catlist;             /* Don't append any more items. */
2451
2452   switch (ffebld_op (expr))
2453     {
2454     case FFEBLD_opCONTER:
2455     case FFEBLD_opSYMTER:
2456     case FFEBLD_opARRAYREF:
2457     case FFEBLD_opFUNCREF:
2458     case FFEBLD_opSUBSTR:
2459     case FFEBLD_opCONVERT:      /* Callers should strip this off beforehand
2460                                    if they don't need to preserve it. */
2461       if (catlist.count == catlist.max)
2462         {                       /* Make a (larger) list. */
2463           ffebld *newx;
2464           int newmax;
2465
2466           newmax = (catlist.max == 0) ? 8 : catlist.max * 2;
2467           newx = malloc_new_ks (malloc_pool_image (), "catlist",
2468                                 newmax * sizeof (newx[0]));
2469           if (catlist.max != 0)
2470             {
2471               memcpy (newx, catlist.exprs, catlist.max * sizeof (newx[0]));
2472               malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2473                               catlist.max * sizeof (newx[0]));
2474             }
2475           catlist.max = newmax;
2476           catlist.exprs = newx;
2477         }
2478       if ((sz = ffebld_size_known (expr)) != FFETARGET_charactersizeNONE)
2479         catlist.minlen += sz;
2480       else
2481         ++catlist.minlen;       /* Not true for F90; can be 0 length. */
2482       if ((sz = ffebld_size_max (expr)) == FFETARGET_charactersizeNONE)
2483         catlist.maxlen = sz;
2484       else
2485         catlist.maxlen += sz;
2486       if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen > max))
2487         {                       /* This item overlaps (or is beyond) the end
2488                                    of the destination. */
2489           switch (ffebld_op (expr))
2490             {
2491             case FFEBLD_opCONTER:
2492             case FFEBLD_opSYMTER:
2493             case FFEBLD_opARRAYREF:
2494             case FFEBLD_opFUNCREF:
2495             case FFEBLD_opSUBSTR:
2496               /* ~~Do useful truncations here. */
2497               break;
2498
2499             default:
2500               assert ("op changed or inconsistent switches!" == NULL);
2501               break;
2502             }
2503         }
2504       catlist.exprs[catlist.count++] = expr;
2505       return catlist;
2506
2507     case FFEBLD_opPAREN:
2508       expr = ffebld_left (expr);
2509       goto recurse;             /* :::::::::::::::::::: */
2510
2511     case FFEBLD_opCONCATENATE:
2512       catlist = ffecom_concat_list_gather_ (catlist, ffebld_left (expr), max);
2513       expr = ffebld_right (expr);
2514       goto recurse;             /* :::::::::::::::::::: */
2515
2516 #if 0                           /* Breaks passing small actual arg to larger
2517                                    dummy arg of sfunc */
2518     case FFEBLD_opCONVERT:
2519       expr = ffebld_left (expr);
2520       {
2521         ffetargetCharacterSize cmax;
2522
2523         cmax = catlist.len + ffebld_size_known (expr);
2524
2525         if ((max == FFETARGET_charactersizeNONE) || (max > cmax))
2526           max = cmax;
2527       }
2528       goto recurse;             /* :::::::::::::::::::: */
2529 #endif
2530
2531     case FFEBLD_opANY:
2532       return catlist;
2533
2534     default:
2535       assert ("bad op in _gather_" == NULL);
2536       return catlist;
2537     }
2538 }
2539
2540 #endif
2541 /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
2542
2543    ffecomConcatList_ catlist;
2544    ffecom_concat_list_kill_(catlist);
2545
2546    Anything allocated within the list info is deallocated.  */
2547
2548 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2549 static void
2550 ffecom_concat_list_kill_ (ffecomConcatList_ catlist)
2551 {
2552   if (catlist.max != 0)
2553     malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2554                     catlist.max * sizeof (catlist.exprs[0]));
2555 }
2556
2557 #endif
2558 /* Make list of concatenated string exprs.
2559
2560    Returns a flattened list of concatenated subexpressions given a
2561    tree of such expressions.  */
2562
2563 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2564 static ffecomConcatList_
2565 ffecom_concat_list_new_ (ffebld expr, ffetargetCharacterSize max)
2566 {
2567   ffecomConcatList_ catlist;
2568
2569   catlist.maxlen = catlist.minlen = catlist.max = catlist.count = 0;
2570   return ffecom_concat_list_gather_ (catlist, expr, max);
2571 }
2572
2573 #endif
2574
2575 /* Provide some kind of useful info on member of aggregate area,
2576    since current g77/gcc technology does not provide debug info
2577    on these members.  */
2578
2579 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2580 static void
2581 ffecom_debug_kludge_ (tree aggr, const char *aggr_type, ffesymbol member,
2582                       tree member_type UNUSED, ffetargetOffset offset)
2583 {
2584   tree value;
2585   tree decl;
2586   int len;
2587   char *buff;
2588   char space[120];
2589 #if 0
2590   tree type_id;
2591
2592   for (type_id = member_type;
2593        TREE_CODE (type_id) != IDENTIFIER_NODE;
2594        )
2595     {
2596       switch (TREE_CODE (type_id))
2597         {
2598         case INTEGER_TYPE:
2599         case REAL_TYPE:
2600           type_id = TYPE_NAME (type_id);
2601           break;
2602
2603         case ARRAY_TYPE:
2604         case COMPLEX_TYPE:
2605           type_id = TREE_TYPE (type_id);
2606           break;
2607
2608         default:
2609           assert ("no IDENTIFIER_NODE for type!" == NULL);
2610           type_id = error_mark_node;
2611           break;
2612         }
2613     }
2614 #endif
2615
2616   if (ffecom_transform_only_dummies_
2617       || !ffe_is_debug_kludge ())
2618     return;     /* Can't do this yet, maybe later. */
2619
2620   len = 60
2621     + strlen (aggr_type)
2622     + IDENTIFIER_LENGTH (DECL_NAME (aggr));
2623 #if 0
2624     + IDENTIFIER_LENGTH (type_id);
2625 #endif
2626
2627   if (((size_t) len) >= ARRAY_SIZE (space))
2628     buff = malloc_new_ks (malloc_pool_image (), "debug_kludge", len + 1);
2629   else
2630     buff = &space[0];
2631
2632   sprintf (&buff[0], "At (%s) `%s' plus %ld bytes",
2633            aggr_type,
2634            IDENTIFIER_POINTER (DECL_NAME (aggr)),
2635            (long int) offset);
2636
2637   value = build_string (len, buff);
2638   TREE_TYPE (value)
2639     = build_type_variant (build_array_type (char_type_node,
2640                                             build_range_type
2641                                             (integer_type_node,
2642                                              integer_one_node,
2643                                              build_int_2 (strlen (buff), 0))),
2644                           1, 0);
2645   decl = build_decl (VAR_DECL,
2646                      ffecom_get_identifier_ (ffesymbol_text (member)),
2647                      TREE_TYPE (value));
2648   TREE_CONSTANT (decl) = 1;
2649   TREE_STATIC (decl) = 1;
2650   DECL_INITIAL (decl) = error_mark_node;
2651   DECL_IN_SYSTEM_HEADER (decl) = 1;     /* Don't let -Wunused complain. */
2652   decl = start_decl (decl, FALSE);
2653   finish_decl (decl, value, FALSE);
2654
2655   if (buff != &space[0])
2656     malloc_kill_ks (malloc_pool_image (), buff, len + 1);
2657 }
2658 #endif
2659
2660 /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
2661
2662    ffesymbol fn;  // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
2663    int i;  // entry# for this entrypoint (used by master fn)
2664    ffecom_do_entrypoint_(s,i);
2665
2666    Makes a public entry point that calls our private master fn (already
2667    compiled).  */
2668
2669 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2670 static void
2671 ffecom_do_entry_ (ffesymbol fn, int entrynum)
2672 {
2673   ffebld item;
2674   tree type;                    /* Type of function. */
2675   tree multi_retval;            /* Var holding return value (union). */
2676   tree result;                  /* Var holding result. */
2677   ffeinfoBasictype bt;
2678   ffeinfoKindtype kt;
2679   ffeglobal g;
2680   ffeglobalType gt;
2681   bool charfunc;                /* All entry points return same type
2682                                    CHARACTER. */
2683   bool cmplxfunc;               /* Use f2c way of returning COMPLEX. */
2684   bool multi;                   /* Master fn has multiple return types. */
2685   bool altreturning = FALSE;    /* This entry point has alternate returns. */
2686   int yes;
2687   int old_lineno = lineno;
2688   char *old_input_filename = input_filename;
2689
2690   input_filename = ffesymbol_where_filename (fn);
2691   lineno = ffesymbol_where_filelinenum (fn);
2692
2693   /* c-parse.y indeed does call suspend_momentary and not only ignores the
2694      return value, but also never calls resume_momentary, when starting an
2695      outer function (see "fndef:", "setspecs:", and so on).  So g77 does the
2696      same thing.  It shouldn't be a problem since start_function calls
2697      temporary_allocation, but it might be necessary.  If it causes a problem
2698      here, then maybe there's a bug lurking in gcc.  NOTE: This identical
2699      comment appears twice in thist file.  */
2700
2701   suspend_momentary ();
2702
2703   ffecom_doing_entry_ = TRUE;   /* Don't bother with array dimensions. */
2704
2705   switch (ffecom_primary_entry_kind_)
2706     {
2707     case FFEINFO_kindFUNCTION:
2708
2709       /* Determine actual return type for function. */
2710
2711       gt = FFEGLOBAL_typeFUNC;
2712       bt = ffesymbol_basictype (fn);
2713       kt = ffesymbol_kindtype (fn);
2714       if (bt == FFEINFO_basictypeNONE)
2715         {
2716           ffeimplic_establish_symbol (fn);
2717           if (ffesymbol_funcresult (fn) != NULL)
2718             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
2719           bt = ffesymbol_basictype (fn);
2720           kt = ffesymbol_kindtype (fn);
2721         }
2722
2723       if (bt == FFEINFO_basictypeCHARACTER)
2724         charfunc = TRUE, cmplxfunc = FALSE;
2725       else if ((bt == FFEINFO_basictypeCOMPLEX)
2726                && ffesymbol_is_f2c (fn))
2727         charfunc = FALSE, cmplxfunc = TRUE;
2728       else
2729         charfunc = cmplxfunc = FALSE;
2730
2731       if (charfunc)
2732         type = ffecom_tree_fun_type_void;
2733       else if (ffesymbol_is_f2c (fn))
2734         type = ffecom_tree_fun_type[bt][kt];
2735       else
2736         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
2737
2738       if ((type == NULL_TREE)
2739           || (TREE_TYPE (type) == NULL_TREE))
2740         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
2741
2742       multi = (ffecom_master_bt_ == FFEINFO_basictypeNONE);
2743       break;
2744
2745     case FFEINFO_kindSUBROUTINE:
2746       gt = FFEGLOBAL_typeSUBR;
2747       bt = FFEINFO_basictypeNONE;
2748       kt = FFEINFO_kindtypeNONE;
2749       if (ffecom_is_altreturning_)
2750         {                       /* Am _I_ altreturning? */
2751           for (item = ffesymbol_dummyargs (fn);
2752                item != NULL;
2753                item = ffebld_trail (item))
2754             {
2755               if (ffebld_op (ffebld_head (item)) == FFEBLD_opSTAR)
2756                 {
2757                   altreturning = TRUE;
2758                   break;
2759                 }
2760             }
2761           if (altreturning)
2762             type = ffecom_tree_subr_type;
2763           else
2764             type = ffecom_tree_fun_type_void;
2765         }
2766       else
2767         type = ffecom_tree_fun_type_void;
2768       charfunc = FALSE;
2769       cmplxfunc = FALSE;
2770       multi = FALSE;
2771       break;
2772
2773     default:
2774       assert ("say what??" == NULL);
2775       /* Fall through. */
2776     case FFEINFO_kindANY:
2777       gt = FFEGLOBAL_typeANY;
2778       bt = FFEINFO_basictypeNONE;
2779       kt = FFEINFO_kindtypeNONE;
2780       type = error_mark_node;
2781       charfunc = FALSE;
2782       cmplxfunc = FALSE;
2783       multi = FALSE;
2784       break;
2785     }
2786
2787   /* build_decl uses the current lineno and input_filename to set the decl
2788      source info.  So, I've putzed with ffestd and ffeste code to update that
2789      source info to point to the appropriate statement just before calling
2790      ffecom_do_entrypoint (which calls this fn).  */
2791
2792   start_function (ffecom_get_external_identifier_ (fn),
2793                   type,
2794                   0,            /* nested/inline */
2795                   1);           /* TREE_PUBLIC */
2796
2797   if (((g = ffesymbol_global (fn)) != NULL)
2798       && ((ffeglobal_type (g) == gt)
2799           || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
2800     {
2801       ffeglobal_set_hook (g, current_function_decl);
2802     }
2803
2804   /* Reset args in master arg list so they get retransitioned. */
2805
2806   for (item = ffecom_master_arglist_;
2807        item != NULL;
2808        item = ffebld_trail (item))
2809     {
2810       ffebld arg;
2811       ffesymbol s;
2812
2813       arg = ffebld_head (item);
2814       if (ffebld_op (arg) != FFEBLD_opSYMTER)
2815         continue;               /* Alternate return or some such thing. */
2816       s = ffebld_symter (arg);
2817       ffesymbol_hook (s).decl_tree = NULL_TREE;
2818       ffesymbol_hook (s).length_tree = NULL_TREE;
2819     }
2820
2821   /* Build dummy arg list for this entry point. */
2822
2823   yes = suspend_momentary ();
2824
2825   if (charfunc || cmplxfunc)
2826     {                           /* Prepend arg for where result goes. */
2827       tree type;
2828       tree length;
2829
2830       if (charfunc)
2831         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
2832       else
2833         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
2834
2835       result = ffecom_get_invented_identifier ("__g77_%s", "result");
2836
2837       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
2838
2839       if (charfunc)
2840         length = ffecom_char_enhance_arg_ (&type, fn);
2841       else
2842         length = NULL_TREE;     /* Not ref'd if !charfunc. */
2843
2844       type = build_pointer_type (type);
2845       result = build_decl (PARM_DECL, result, type);
2846
2847       push_parm_decl (result);
2848       ffecom_func_result_ = result;
2849
2850       if (charfunc)
2851         {
2852           push_parm_decl (length);
2853           ffecom_func_length_ = length;
2854         }
2855     }
2856   else
2857     result = DECL_RESULT (current_function_decl);
2858
2859   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn), FALSE);
2860
2861   resume_momentary (yes);
2862
2863   store_parm_decls (0);
2864
2865   ffecom_start_compstmt ();
2866   /* Disallow temp vars at this level.  */
2867   current_binding_level->prep_state = 2;
2868
2869   /* Make local var to hold return type for multi-type master fn. */
2870
2871   if (multi)
2872     {
2873       yes = suspend_momentary ();
2874
2875       multi_retval = ffecom_get_invented_identifier ("__g77_%s",
2876                                                      "multi_retval");
2877       multi_retval = build_decl (VAR_DECL, multi_retval,
2878                                  ffecom_multi_type_node_);
2879       multi_retval = start_decl (multi_retval, FALSE);
2880       finish_decl (multi_retval, NULL_TREE, FALSE);
2881
2882       resume_momentary (yes);
2883     }
2884   else
2885     multi_retval = NULL_TREE;   /* Not actually ref'd if !multi. */
2886
2887   /* Here we emit the actual code for the entry point. */
2888
2889   {
2890     ffebld list;
2891     ffebld arg;
2892     ffesymbol s;
2893     tree arglist = NULL_TREE;
2894     tree *plist = &arglist;
2895     tree prepend;
2896     tree call;
2897     tree actarg;
2898     tree master_fn;
2899
2900     /* Prepare actual arg list based on master arg list. */
2901
2902     for (list = ffecom_master_arglist_;
2903          list != NULL;
2904          list = ffebld_trail (list))
2905       {
2906         arg = ffebld_head (list);
2907         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2908           continue;
2909         s = ffebld_symter (arg);
2910         if (ffesymbol_hook (s).decl_tree == NULL_TREE
2911             || ffesymbol_hook (s).decl_tree == error_mark_node)
2912           actarg = null_pointer_node;   /* We don't have this arg. */
2913         else
2914           actarg = ffesymbol_hook (s).decl_tree;
2915         *plist = build_tree_list (NULL_TREE, actarg);
2916         plist = &TREE_CHAIN (*plist);
2917       }
2918
2919     /* This code appends the length arguments for character
2920        variables/arrays.  */
2921
2922     for (list = ffecom_master_arglist_;
2923          list != NULL;
2924          list = ffebld_trail (list))
2925       {
2926         arg = ffebld_head (list);
2927         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2928           continue;
2929         s = ffebld_symter (arg);
2930         if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
2931           continue;             /* Only looking for CHARACTER arguments. */
2932         if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
2933           continue;             /* Only looking for variables and arrays. */
2934         if (ffesymbol_hook (s).length_tree == NULL_TREE
2935             || ffesymbol_hook (s).length_tree == error_mark_node)
2936           actarg = ffecom_f2c_ftnlen_zero_node; /* We don't have this arg. */
2937         else
2938           actarg = ffesymbol_hook (s).length_tree;
2939         *plist = build_tree_list (NULL_TREE, actarg);
2940         plist = &TREE_CHAIN (*plist);
2941       }
2942
2943     /* Prepend character-value return info to actual arg list. */
2944
2945     if (charfunc)
2946       {
2947         prepend = build_tree_list (NULL_TREE, ffecom_func_result_);
2948         TREE_CHAIN (prepend)
2949           = build_tree_list (NULL_TREE, ffecom_func_length_);
2950         TREE_CHAIN (TREE_CHAIN (prepend)) = arglist;
2951         arglist = prepend;
2952       }
2953
2954     /* Prepend multi-type return value to actual arg list. */
2955
2956     if (multi)
2957       {
2958         prepend
2959           = build_tree_list (NULL_TREE,
2960                              ffecom_1 (ADDR_EXPR,
2961                               build_pointer_type (TREE_TYPE (multi_retval)),
2962                                        multi_retval));
2963         TREE_CHAIN (prepend) = arglist;
2964         arglist = prepend;
2965       }
2966
2967     /* Prepend my entry-point number to the actual arg list. */
2968
2969     prepend = build_tree_list (NULL_TREE, build_int_2 (entrynum, 0));
2970     TREE_CHAIN (prepend) = arglist;
2971     arglist = prepend;
2972
2973     /* Build the call to the master function. */
2974
2975     master_fn = ffecom_1_fn (ffecom_previous_function_decl_);
2976     call = ffecom_3s (CALL_EXPR,
2977                       TREE_TYPE (TREE_TYPE (TREE_TYPE (master_fn))),
2978                       master_fn, arglist, NULL_TREE);
2979
2980     /* Decide whether the master function is a function or subroutine, and
2981        handle the return value for my entry point. */
2982
2983     if (charfunc || ((ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
2984                      && !altreturning))
2985       {
2986         expand_expr_stmt (call);
2987         expand_null_return ();
2988       }
2989     else if (multi && cmplxfunc)
2990       {
2991         expand_expr_stmt (call);
2992         result
2993           = ffecom_1 (INDIRECT_REF,
2994                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2995                       result);
2996         result = ffecom_modify (NULL_TREE, result,
2997                                 ffecom_2 (COMPONENT_REF, TREE_TYPE (result),
2998                                           multi_retval,
2999                                           ffecom_multi_fields_[bt][kt]));
3000         expand_expr_stmt (result);
3001         expand_null_return ();
3002       }
3003     else if (multi)
3004       {
3005         expand_expr_stmt (call);
3006         result
3007           = ffecom_modify (NULL_TREE, result,
3008                            convert (TREE_TYPE (result),
3009                                     ffecom_2 (COMPONENT_REF,
3010                                               ffecom_tree_type[bt][kt],
3011                                               multi_retval,
3012                                               ffecom_multi_fields_[bt][kt])));
3013         expand_return (result);
3014       }
3015     else if (cmplxfunc)
3016       {
3017         result
3018           = ffecom_1 (INDIRECT_REF,
3019                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
3020                       result);
3021         result = ffecom_modify (NULL_TREE, result, call);
3022         expand_expr_stmt (result);
3023         expand_null_return ();
3024       }
3025     else
3026       {
3027         result = ffecom_modify (NULL_TREE,
3028                                 result,
3029                                 convert (TREE_TYPE (result),
3030                                          call));
3031         expand_return (result);
3032       }
3033
3034     clear_momentary ();
3035   }
3036
3037   ffecom_end_compstmt ();
3038
3039   finish_function (0);
3040
3041   lineno = old_lineno;
3042   input_filename = old_input_filename;
3043
3044   ffecom_doing_entry_ = FALSE;
3045 }
3046
3047 #endif
3048 /* Transform expr into gcc tree with possible destination
3049
3050    Recursive descent on expr while making corresponding tree nodes and
3051    attaching type info and such.  If destination supplied and compatible
3052    with temporary that would be made in certain cases, temporary isn't
3053    made, destination used instead, and dest_used flag set TRUE.  */
3054
3055 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3056 static tree
3057 ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
3058               bool *dest_used, bool assignp, bool widenp)
3059 {
3060   tree item;
3061   tree list;
3062   tree args;
3063   ffeinfoBasictype bt;
3064   ffeinfoKindtype kt;
3065   tree t;
3066   tree dt;                      /* decl_tree for an ffesymbol. */
3067   tree tree_type, tree_type_x;
3068   tree left, right;
3069   ffesymbol s;
3070   enum tree_code code;
3071
3072   assert (expr != NULL);
3073
3074   if (dest_used != NULL)
3075     *dest_used = FALSE;
3076
3077   bt = ffeinfo_basictype (ffebld_info (expr));
3078   kt = ffeinfo_kindtype (ffebld_info (expr));
3079   tree_type = ffecom_tree_type[bt][kt];
3080
3081   /* Widen integral arithmetic as desired while preserving signedness.  */
3082   tree_type_x = NULL_TREE;
3083   if (widenp && tree_type
3084       && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
3085       && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
3086     tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
3087
3088   switch (ffebld_op (expr))
3089     {
3090     case FFEBLD_opACCTER:
3091       {
3092         ffebitCount i;
3093         ffebit bits = ffebld_accter_bits (expr);
3094         ffetargetOffset source_offset = 0;
3095         ffetargetOffset dest_offset = ffebld_accter_pad (expr);
3096         tree purpose;
3097
3098         assert (dest_offset == 0
3099                 || (bt == FFEINFO_basictypeCHARACTER
3100                     && kt == FFEINFO_kindtypeCHARACTER1));
3101
3102         list = item = NULL;
3103         for (;;)
3104           {
3105             ffebldConstantUnion cu;
3106             ffebitCount length;
3107             bool value;
3108             ffebldConstantArray ca = ffebld_accter (expr);
3109
3110             ffebit_test (bits, source_offset, &value, &length);
3111             if (length == 0)
3112               break;
3113
3114             if (value)
3115               {
3116                 for (i = 0; i < length; ++i)
3117                   {
3118                     cu = ffebld_constantarray_get (ca, bt, kt,
3119                                                    source_offset + i);
3120
3121                     t = ffecom_constantunion (&cu, bt, kt, tree_type);
3122
3123                     if (i == 0
3124                         && dest_offset != 0)
3125                       purpose = build_int_2 (dest_offset, 0);
3126                     else
3127                       purpose = NULL_TREE;
3128
3129                     if (list == NULL_TREE)
3130                       list = item = build_tree_list (purpose, t);
3131                     else
3132                       {
3133                         TREE_CHAIN (item) = build_tree_list (purpose, t);
3134                         item = TREE_CHAIN (item);
3135                       }
3136                   }
3137               }
3138             source_offset += length;
3139             dest_offset += length;
3140           }
3141       }
3142
3143       item = build_int_2 ((ffebld_accter_size (expr)
3144                            + ffebld_accter_pad (expr)) - 1, 0);
3145       ffebit_kill (ffebld_accter_bits (expr));
3146       TREE_TYPE (item) = ffecom_integer_type_node;
3147       item
3148         = build_array_type
3149           (tree_type,
3150            build_range_type (ffecom_integer_type_node,
3151                              ffecom_integer_zero_node,
3152                              item));
3153       list = build (CONSTRUCTOR, item, NULL_TREE, list);
3154       TREE_CONSTANT (list) = 1;
3155       TREE_STATIC (list) = 1;
3156       return list;
3157
3158     case FFEBLD_opARRTER:
3159       {
3160         ffetargetOffset i;
3161
3162         list = NULL_TREE;
3163         if (ffebld_arrter_pad (expr) == 0)
3164           item = NULL_TREE;
3165         else
3166           {
3167             assert (bt == FFEINFO_basictypeCHARACTER
3168                     && kt == FFEINFO_kindtypeCHARACTER1);
3169
3170             /* Becomes PURPOSE first time through loop.  */
3171             item = build_int_2 (ffebld_arrter_pad (expr), 0);
3172           }
3173
3174         for (i = 0; i < ffebld_arrter_size (expr); ++i)
3175           {
3176             ffebldConstantUnion cu
3177             = ffebld_constantarray_get (ffebld_arrter (expr), bt, kt, i);
3178
3179             t = ffecom_constantunion (&cu, bt, kt, tree_type);
3180
3181             if (list == NULL_TREE)
3182               /* Assume item is PURPOSE first time through loop.  */
3183               list = item = build_tree_list (item, t);
3184             else
3185               {
3186                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
3187                 item = TREE_CHAIN (item);
3188               }
3189           }
3190       }
3191
3192       item = build_int_2 ((ffebld_arrter_size (expr)
3193                           + ffebld_arrter_pad (expr)) - 1, 0);
3194       TREE_TYPE (item) = ffecom_integer_type_node;
3195       item
3196         = build_array_type
3197           (tree_type,
3198            build_range_type (ffecom_integer_type_node,
3199                              ffecom_integer_zero_node,
3200                              item));
3201       list = build (CONSTRUCTOR, item, NULL_TREE, list);
3202       TREE_CONSTANT (list) = 1;
3203       TREE_STATIC (list) = 1;
3204       return list;
3205
3206     case FFEBLD_opCONTER:
3207       assert (ffebld_conter_pad (expr) == 0);
3208       item
3209         = ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr)),
3210                                 bt, kt, tree_type);
3211       return item;
3212
3213     case FFEBLD_opSYMTER:
3214       if ((ffebld_symter_generic (expr) != FFEINTRIN_genNONE)
3215           || (ffebld_symter_specific (expr) != FFEINTRIN_specNONE))
3216         return ffecom_ptr_to_expr (expr);       /* Same as %REF(intrinsic). */
3217       s = ffebld_symter (expr);
3218       t = ffesymbol_hook (s).decl_tree;
3219
3220       if (assignp)
3221         {                       /* ASSIGN'ed-label expr. */
3222           if (ffe_is_ugly_assign ())
3223             {
3224               /* User explicitly wants ASSIGN'ed variables to be at the same
3225                  memory address as the variables when used in non-ASSIGN
3226                  contexts.  That can make old, arcane, non-standard code
3227                  work, but don't try to do it when a pointer wouldn't fit
3228                  in the normal variable (take other approach, and warn,
3229                  instead).  */
3230
3231               if (t == NULL_TREE)
3232                 {
3233                   s = ffecom_sym_transform_ (s);
3234                   t = ffesymbol_hook (s).decl_tree;
3235                   assert (t != NULL_TREE);
3236                 }
3237
3238               if (t == error_mark_node)
3239                 return t;
3240
3241               if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t)))
3242                   >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
3243                 {
3244                   if (ffesymbol_hook (s).addr)
3245                     t = ffecom_1 (INDIRECT_REF,
3246                                   TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3247                   return t;
3248                 }
3249
3250               if (ffesymbol_hook (s).assign_tree == NULL_TREE)
3251                 {
3252                   ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling",
3253                                     FFEBAD_severityWARNING);
3254                   ffebad_string (ffesymbol_text (s));
3255                   ffebad_here (0, ffesymbol_where_line (s),
3256                                ffesymbol_where_column (s));
3257                   ffebad_finish ();
3258                 }
3259             }
3260
3261           /* Don't use the normal variable's tree for ASSIGN, though mark
3262              it as in the system header (housekeeping).  Use an explicit,
3263              specially created sibling that is known to be wide enough
3264              to hold pointers to labels.  */
3265
3266           if (t != NULL_TREE
3267               && TREE_CODE (t) == VAR_DECL)
3268             DECL_IN_SYSTEM_HEADER (t) = 1;      /* Don't let -Wunused complain. */
3269
3270           t = ffesymbol_hook (s).assign_tree;
3271           if (t == NULL_TREE)
3272             {
3273               s = ffecom_sym_transform_assign_ (s);
3274               t = ffesymbol_hook (s).assign_tree;
3275               assert (t != NULL_TREE);
3276             }
3277         }
3278       else
3279         {
3280           if (t == NULL_TREE)
3281             {
3282               s = ffecom_sym_transform_ (s);
3283               t = ffesymbol_hook (s).decl_tree;
3284               assert (t != NULL_TREE);
3285             }
3286           if (ffesymbol_hook (s).addr)
3287             t = ffecom_1 (INDIRECT_REF,
3288                           TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3289         }
3290       return t;
3291
3292     case FFEBLD_opARRAYREF:
3293       return ffecom_arrayref_ (NULL_TREE, expr, 0);
3294
3295     case FFEBLD_opUPLUS:
3296       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3297       return ffecom_1 (NOP_EXPR, tree_type, left);
3298
3299     case FFEBLD_opPAREN:
3300       /* ~~~Make sure Fortran rules respected here */
3301       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3302       return ffecom_1 (NOP_EXPR, tree_type, left);
3303
3304     case FFEBLD_opUMINUS:
3305       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3306       if (tree_type_x)
3307         {
3308           tree_type = tree_type_x;
3309           left = convert (tree_type, left);
3310         }
3311       return ffecom_1 (NEGATE_EXPR, tree_type, left);
3312
3313     case FFEBLD_opADD:
3314       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3315       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3316       if (tree_type_x)
3317         {
3318           tree_type = tree_type_x;
3319           left = convert (tree_type, left);
3320           right = convert (tree_type, right);
3321         }
3322       return ffecom_2 (PLUS_EXPR, tree_type, left, right);
3323
3324     case FFEBLD_opSUBTRACT:
3325       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3326       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3327       if (tree_type_x)
3328         {
3329           tree_type = tree_type_x;
3330           left = convert (tree_type, left);
3331           right = convert (tree_type, right);
3332         }
3333       return ffecom_2 (MINUS_EXPR, tree_type, left, right);
3334
3335     case FFEBLD_opMULTIPLY:
3336       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3337       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3338       if (tree_type_x)
3339         {
3340           tree_type = tree_type_x;
3341           left = convert (tree_type, left);
3342           right = convert (tree_type, right);
3343         }
3344       return ffecom_2 (MULT_EXPR, tree_type, left, right);
3345
3346     case FFEBLD_opDIVIDE:
3347       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3348       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3349       if (tree_type_x)
3350         {
3351           tree_type = tree_type_x;
3352           left = convert (tree_type, left);
3353           right = convert (tree_type, right);
3354         }
3355       return ffecom_tree_divide_ (tree_type, left, right,
3356                                   dest_tree, dest, dest_used,
3357                                   ffebld_nonter_hook (expr));
3358
3359     case FFEBLD_opPOWER:
3360       {
3361         ffebld left = ffebld_left (expr);
3362         ffebld right = ffebld_right (expr);
3363         ffecomGfrt code;
3364         ffeinfoKindtype rtkt;
3365         ffeinfoKindtype ltkt;
3366
3367         switch (ffeinfo_basictype (ffebld_info (right)))
3368           {
3369           case FFEINFO_basictypeINTEGER:
3370             if (1 || optimize)
3371               {
3372                 item = ffecom_expr_power_integer_ (expr);
3373                 if (item != NULL_TREE)
3374                   return item;
3375               }
3376
3377             rtkt = FFEINFO_kindtypeINTEGER1;
3378             switch (ffeinfo_basictype (ffebld_info (left)))
3379               {
3380               case FFEINFO_basictypeINTEGER:
3381                 if ((ffeinfo_kindtype (ffebld_info (left))
3382                     == FFEINFO_kindtypeINTEGER4)
3383                     || (ffeinfo_kindtype (ffebld_info (right))
3384                         == FFEINFO_kindtypeINTEGER4))
3385                   {
3386                     code = FFECOM_gfrtPOW_QQ;
3387                     ltkt = FFEINFO_kindtypeINTEGER4;
3388                     rtkt = FFEINFO_kindtypeINTEGER4;
3389                   }
3390                 else
3391                   {
3392                     code = FFECOM_gfrtPOW_II;
3393                     ltkt = FFEINFO_kindtypeINTEGER1;
3394                   }
3395                 break;
3396
3397               case FFEINFO_basictypeREAL:
3398                 if (ffeinfo_kindtype (ffebld_info (left))
3399                     == FFEINFO_kindtypeREAL1)
3400                   {
3401                     code = FFECOM_gfrtPOW_RI;
3402                     ltkt = FFEINFO_kindtypeREAL1;
3403                   }
3404                 else
3405                   {
3406                     code = FFECOM_gfrtPOW_DI;
3407                     ltkt = FFEINFO_kindtypeREAL2;
3408                   }
3409                 break;
3410
3411               case FFEINFO_basictypeCOMPLEX:
3412                 if (ffeinfo_kindtype (ffebld_info (left))
3413                     == FFEINFO_kindtypeREAL1)
3414                   {
3415                     code = FFECOM_gfrtPOW_CI;   /* Overlapping result okay. */
3416                     ltkt = FFEINFO_kindtypeREAL1;
3417                   }
3418                 else
3419                   {
3420                     code = FFECOM_gfrtPOW_ZI;   /* Overlapping result okay. */
3421                     ltkt = FFEINFO_kindtypeREAL2;
3422                   }
3423                 break;
3424
3425               default:
3426                 assert ("bad pow_*i" == NULL);
3427                 code = FFECOM_gfrtPOW_CI;       /* Overlapping result okay. */
3428                 ltkt = FFEINFO_kindtypeREAL1;
3429                 break;
3430               }
3431             if (ffeinfo_kindtype (ffebld_info (left)) != ltkt)
3432               left = ffeexpr_convert (left, NULL, NULL,
3433                                       ffeinfo_basictype (ffebld_info (left)),
3434                                       ltkt, 0,
3435                                       FFETARGET_charactersizeNONE,
3436                                       FFEEXPR_contextLET);
3437             if (ffeinfo_kindtype (ffebld_info (right)) != rtkt)
3438               right = ffeexpr_convert (right, NULL, NULL,
3439                                        FFEINFO_basictypeINTEGER,
3440                                        rtkt, 0,
3441                                        FFETARGET_charactersizeNONE,
3442                                        FFEEXPR_contextLET);
3443             break;
3444
3445           case FFEINFO_basictypeREAL:
3446             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3447               left = ffeexpr_convert (left, NULL, NULL, FFEINFO_basictypeREAL,
3448                                       FFEINFO_kindtypeREALDOUBLE, 0,
3449                                       FFETARGET_charactersizeNONE,
3450                                       FFEEXPR_contextLET);
3451             if (ffeinfo_kindtype (ffebld_info (right))
3452                 == FFEINFO_kindtypeREAL1)
3453               right = ffeexpr_convert (right, NULL, NULL,
3454                                        FFEINFO_basictypeREAL,
3455                                        FFEINFO_kindtypeREALDOUBLE, 0,
3456                                        FFETARGET_charactersizeNONE,
3457                                        FFEEXPR_contextLET);
3458             code = FFECOM_gfrtPOW_DD;
3459             break;
3460
3461           case FFEINFO_basictypeCOMPLEX:
3462             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3463               left = ffeexpr_convert (left, NULL, NULL,
3464                                       FFEINFO_basictypeCOMPLEX,
3465                                       FFEINFO_kindtypeREALDOUBLE, 0,
3466                                       FFETARGET_charactersizeNONE,
3467                                       FFEEXPR_contextLET);
3468             if (ffeinfo_kindtype (ffebld_info (right))
3469                 == FFEINFO_kindtypeREAL1)
3470               right = ffeexpr_convert (right, NULL, NULL,
3471                                        FFEINFO_basictypeCOMPLEX,
3472                                        FFEINFO_kindtypeREALDOUBLE, 0,
3473                                        FFETARGET_charactersizeNONE,
3474                                        FFEEXPR_contextLET);
3475             code = FFECOM_gfrtPOW_ZZ;   /* Overlapping result okay. */
3476             break;
3477
3478           default:
3479             assert ("bad pow_x*" == NULL);
3480             code = FFECOM_gfrtPOW_II;
3481             break;
3482           }
3483         return ffecom_call_binop_ (ffecom_gfrt_tree_ (code),
3484                                    ffecom_gfrt_kindtype (code),
3485                                    (ffe_is_f2c_library ()
3486                                     && ffecom_gfrt_complex_[code]),
3487                                    tree_type, left, right,
3488                                    dest_tree, dest, dest_used,
3489                                    NULL_TREE, FALSE,
3490                                    ffebld_nonter_hook (expr));
3491       }
3492
3493     case FFEBLD_opNOT:
3494       switch (bt)
3495         {
3496         case FFEINFO_basictypeLOGICAL:
3497           item = ffecom_truth_value_invert (ffecom_expr (ffebld_left (expr)));
3498           return convert (tree_type, item);
3499
3500         case FFEINFO_basictypeINTEGER:
3501           return ffecom_1 (BIT_NOT_EXPR, tree_type,
3502                            ffecom_expr (ffebld_left (expr)));
3503
3504         default:
3505           assert ("NOT bad basictype" == NULL);
3506           /* Fall through. */
3507         case FFEINFO_basictypeANY:
3508           return error_mark_node;
3509         }
3510       break;
3511
3512     case FFEBLD_opFUNCREF:
3513       assert (ffeinfo_basictype (ffebld_info (expr))
3514               != FFEINFO_basictypeCHARACTER);
3515       /* Fall through.   */
3516     case FFEBLD_opSUBRREF:
3517       if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
3518           == FFEINFO_whereINTRINSIC)
3519         {                       /* Invocation of an intrinsic. */
3520           item = ffecom_expr_intrinsic_ (expr, dest_tree, dest,
3521                                          dest_used);
3522           return item;
3523         }
3524       s = ffebld_symter (ffebld_left (expr));
3525       dt = ffesymbol_hook (s).decl_tree;
3526       if (dt == NULL_TREE)
3527         {
3528           s = ffecom_sym_transform_ (s);
3529           dt = ffesymbol_hook (s).decl_tree;
3530         }
3531       if (dt == error_mark_node)
3532         return dt;
3533
3534       if (ffesymbol_hook (s).addr)
3535         item = dt;
3536       else
3537         item = ffecom_1_fn (dt);
3538
3539       if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
3540         args = ffecom_list_expr (ffebld_right (expr));
3541       else
3542         args = ffecom_list_ptr_to_expr (ffebld_right (expr));
3543
3544       if (args == error_mark_node)
3545         return error_mark_node;
3546
3547       item = ffecom_call_ (item, kt,
3548                            ffesymbol_is_f2c (s)
3549                            && (bt == FFEINFO_basictypeCOMPLEX)
3550                            && (ffesymbol_where (s)
3551                                != FFEINFO_whereCONSTANT),
3552                            tree_type,
3553                            args,
3554                            dest_tree, dest, dest_used,
3555                            error_mark_node, FALSE,
3556                            ffebld_nonter_hook (expr));
3557       TREE_SIDE_EFFECTS (item) = 1;
3558       return item;
3559
3560     case FFEBLD_opAND:
3561       switch (bt)
3562         {
3563         case FFEINFO_basictypeLOGICAL:
3564           item
3565             = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3566                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3567                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3568           return convert (tree_type, item);
3569
3570         case FFEINFO_basictypeINTEGER:
3571           return ffecom_2 (BIT_AND_EXPR, tree_type,
3572                            ffecom_expr (ffebld_left (expr)),
3573                            ffecom_expr (ffebld_right (expr)));
3574
3575         default:
3576           assert ("AND bad basictype" == NULL);
3577           /* Fall through. */
3578         case FFEINFO_basictypeANY:
3579           return error_mark_node;
3580         }
3581       break;
3582
3583     case FFEBLD_opOR:
3584       switch (bt)
3585         {
3586         case FFEINFO_basictypeLOGICAL:
3587           item
3588             = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
3589                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3590                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3591           return convert (tree_type, item);
3592
3593         case FFEINFO_basictypeINTEGER:
3594           return ffecom_2 (BIT_IOR_EXPR, tree_type,
3595                            ffecom_expr (ffebld_left (expr)),
3596                            ffecom_expr (ffebld_right (expr)));
3597
3598         default:
3599           assert ("OR bad basictype" == NULL);
3600           /* Fall through. */
3601         case FFEINFO_basictypeANY:
3602           return error_mark_node;
3603         }
3604       break;
3605
3606     case FFEBLD_opXOR:
3607     case FFEBLD_opNEQV:
3608       switch (bt)
3609         {
3610         case FFEINFO_basictypeLOGICAL:
3611           item
3612             = ffecom_2 (NE_EXPR, integer_type_node,
3613                         ffecom_expr (ffebld_left (expr)),
3614                         ffecom_expr (ffebld_right (expr)));
3615           return convert (tree_type, ffecom_truth_value (item));
3616
3617         case FFEINFO_basictypeINTEGER:
3618           return ffecom_2 (BIT_XOR_EXPR, tree_type,
3619                            ffecom_expr (ffebld_left (expr)),
3620                            ffecom_expr (ffebld_right (expr)));
3621
3622         default:
3623           assert ("XOR/NEQV bad basictype" == NULL);
3624           /* Fall through. */
3625         case FFEINFO_basictypeANY:
3626           return error_mark_node;
3627         }
3628       break;
3629
3630     case FFEBLD_opEQV:
3631       switch (bt)
3632         {
3633         case FFEINFO_basictypeLOGICAL:
3634           item
3635             = ffecom_2 (EQ_EXPR, integer_type_node,
3636                         ffecom_expr (ffebld_left (expr)),
3637                         ffecom_expr (ffebld_right (expr)));
3638           return convert (tree_type, ffecom_truth_value (item));
3639
3640         case FFEINFO_basictypeINTEGER:
3641           return
3642             ffecom_1 (BIT_NOT_EXPR, tree_type,
3643                       ffecom_2 (BIT_XOR_EXPR, tree_type,
3644                                 ffecom_expr (ffebld_left (expr)),
3645                                 ffecom_expr (ffebld_right (expr))));
3646
3647         default:
3648           assert ("EQV bad basictype" == NULL);
3649           /* Fall through. */
3650         case FFEINFO_basictypeANY:
3651           return error_mark_node;
3652         }
3653       break;
3654
3655     case FFEBLD_opCONVERT:
3656       if (ffebld_op (ffebld_left (expr)) == FFEBLD_opANY)
3657         return error_mark_node;
3658
3659       switch (bt)
3660         {
3661         case FFEINFO_basictypeLOGICAL:
3662         case FFEINFO_basictypeINTEGER:
3663         case FFEINFO_basictypeREAL:
3664           return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3665
3666         case FFEINFO_basictypeCOMPLEX:
3667           switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3668             {
3669             case FFEINFO_basictypeINTEGER:
3670             case FFEINFO_basictypeLOGICAL:
3671             case FFEINFO_basictypeREAL:
3672               item = ffecom_expr (ffebld_left (expr));
3673               if (item == error_mark_node)
3674                 return error_mark_node;
3675               /* convert() takes care of converting to the subtype first,
3676                  at least in gcc-2.7.2. */
3677               item = convert (tree_type, item);
3678               return item;
3679
3680             case FFEINFO_basictypeCOMPLEX:
3681               return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3682
3683             default:
3684               assert ("CONVERT COMPLEX bad basictype" == NULL);
3685               /* Fall through. */
3686             case FFEINFO_basictypeANY:
3687               return error_mark_node;
3688             }
3689           break;
3690
3691         default:
3692           assert ("CONVERT bad basictype" == NULL);
3693           /* Fall through. */
3694         case FFEINFO_basictypeANY:
3695           return error_mark_node;
3696         }
3697       break;
3698
3699     case FFEBLD_opLT:
3700       code = LT_EXPR;
3701       goto relational;          /* :::::::::::::::::::: */
3702
3703     case FFEBLD_opLE:
3704       code = LE_EXPR;
3705       goto relational;          /* :::::::::::::::::::: */
3706
3707     case FFEBLD_opEQ:
3708       code = EQ_EXPR;
3709       goto relational;          /* :::::::::::::::::::: */
3710
3711     case FFEBLD_opNE:
3712       code = NE_EXPR;
3713       goto relational;          /* :::::::::::::::::::: */
3714
3715     case FFEBLD_opGT:
3716       code = GT_EXPR;
3717       goto relational;          /* :::::::::::::::::::: */
3718
3719     case FFEBLD_opGE:
3720       code = GE_EXPR;
3721
3722     relational:         /* :::::::::::::::::::: */
3723       switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3724         {
3725         case FFEINFO_basictypeLOGICAL:
3726         case FFEINFO_basictypeINTEGER:
3727         case FFEINFO_basictypeREAL:
3728           item = ffecom_2 (code, integer_type_node,
3729                            ffecom_expr (ffebld_left (expr)),
3730                            ffecom_expr (ffebld_right (expr)));
3731           return convert (tree_type, item);
3732
3733         case FFEINFO_basictypeCOMPLEX:
3734           assert (code == EQ_EXPR || code == NE_EXPR);
3735           {
3736             tree real_type;
3737             tree arg1 = ffecom_expr (ffebld_left (expr));
3738             tree arg2 = ffecom_expr (ffebld_right (expr));
3739
3740             if (arg1 == error_mark_node || arg2 == error_mark_node)
3741               return error_mark_node;
3742
3743             arg1 = ffecom_save_tree (arg1);
3744             arg2 = ffecom_save_tree (arg2);
3745
3746             if (TREE_CODE (TREE_TYPE (arg1)) == COMPLEX_TYPE)
3747               {
3748                 real_type = TREE_TYPE (TREE_TYPE (arg1));
3749                 assert (real_type == TREE_TYPE (TREE_TYPE (arg2)));
3750               }
3751             else
3752               {
3753                 real_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg1)));
3754                 assert (real_type == TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg2))));
3755               }
3756
3757             item
3758               = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3759                           ffecom_2 (EQ_EXPR, integer_type_node,
3760                                   ffecom_1 (REALPART_EXPR, real_type, arg1),
3761                                  ffecom_1 (REALPART_EXPR, real_type, arg2)),
3762                           ffecom_2 (EQ_EXPR, integer_type_node,
3763                                   ffecom_1 (IMAGPART_EXPR, real_type, arg1),
3764                                     ffecom_1 (IMAGPART_EXPR, real_type,
3765                                               arg2)));
3766             if (code == EQ_EXPR)
3767               item = ffecom_truth_value (item);
3768             else
3769               item = ffecom_truth_value_invert (item);
3770             return convert (tree_type, item);
3771           }
3772
3773         case FFEINFO_basictypeCHARACTER:
3774           {
3775             ffebld left = ffebld_left (expr);
3776             ffebld right = ffebld_right (expr);
3777             tree left_tree;
3778             tree right_tree;
3779             tree left_length;
3780             tree right_length;
3781
3782             /* f2c run-time functions do the implicit blank-padding for us,
3783                so we don't usually have to implement blank-padding ourselves.
3784                (The exception is when we pass an argument to a separately
3785                compiled statement function -- if we know the arg is not the
3786                same length as the dummy, we must truncate or extend it.  If
3787                we "inline" statement functions, that necessity goes away as
3788                well.)
3789
3790                Strip off the CONVERT operators that blank-pad.  (Truncation by
3791                CONVERT shouldn't happen here, but it can happen in
3792                assignments.) */
3793
3794             while (ffebld_op (left) == FFEBLD_opCONVERT)
3795               left = ffebld_left (left);
3796             while (ffebld_op (right) == FFEBLD_opCONVERT)
3797               right = ffebld_left (right);
3798
3799             left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
3800             right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
3801
3802             if (left_tree == error_mark_node || left_length == error_mark_node
3803                 || right_tree == error_mark_node
3804                 || right_length == error_mark_node)
3805               return error_mark_node;
3806
3807             if ((ffebld_size_known (left) == 1)
3808                 && (ffebld_size_known (right) == 1))
3809               {
3810                 left_tree
3811                   = ffecom_1 (INDIRECT_REF,
3812                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3813                               left_tree);
3814                 right_tree
3815                   = ffecom_1 (INDIRECT_REF,
3816                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3817                               right_tree);
3818
3819                 item
3820                   = ffecom_2 (code, integer_type_node,
3821                               ffecom_2 (ARRAY_REF,
3822                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3823                                         left_tree,
3824                                         integer_one_node),
3825                               ffecom_2 (ARRAY_REF,
3826                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3827                                         right_tree,
3828                                         integer_one_node));
3829               }
3830             else
3831               {
3832                 item = build_tree_list (NULL_TREE, left_tree);
3833                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, right_tree);
3834                 TREE_CHAIN (TREE_CHAIN (item)) = build_tree_list (NULL_TREE,
3835                                                                left_length);
3836                 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
3837                   = build_tree_list (NULL_TREE, right_length);
3838                 item = ffecom_call_gfrt (FFECOM_gfrtCMP, item, NULL_TREE);
3839                 item = ffecom_2 (code, integer_type_node,
3840                                  item,
3841                                  convert (TREE_TYPE (item),
3842                                           integer_zero_node));
3843               }
3844             item = convert (tree_type, item);
3845           }
3846
3847           return item;
3848
3849         default:
3850           assert ("relational bad basictype" == NULL);
3851           /* Fall through. */
3852         case FFEINFO_basictypeANY:
3853           return error_mark_node;
3854         }
3855       break;
3856
3857     case FFEBLD_opPERCENT_LOC:
3858       item = ffecom_arg_ptr_to_expr (ffebld_left (expr), &list);
3859       return convert (tree_type, item);
3860
3861     case FFEBLD_opITEM:
3862     case FFEBLD_opSTAR:
3863     case FFEBLD_opBOUNDS:
3864     case FFEBLD_opREPEAT:
3865     case FFEBLD_opLABTER:
3866     case FFEBLD_opLABTOK:
3867     case FFEBLD_opIMPDO:
3868     case FFEBLD_opCONCATENATE:
3869     case FFEBLD_opSUBSTR:
3870     default:
3871       assert ("bad op" == NULL);
3872       /* Fall through. */
3873     case FFEBLD_opANY:
3874       return error_mark_node;
3875     }
3876
3877 #if 1
3878   assert ("didn't think anything got here anymore!!" == NULL);
3879 #else
3880   switch (ffebld_arity (expr))
3881     {
3882     case 2:
3883       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3884       TREE_OPERAND (item, 1) = ffecom_expr (ffebld_right (expr));
3885       if (TREE_OPERAND (item, 0) == error_mark_node
3886           || TREE_OPERAND (item, 1) == error_mark_node)
3887         return error_mark_node;
3888       break;
3889
3890     case 1:
3891       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3892       if (TREE_OPERAND (item, 0) == error_mark_node)
3893         return error_mark_node;
3894       break;
3895
3896     default:
3897       break;
3898     }
3899
3900   return fold (item);
3901 #endif
3902 }
3903
3904 #endif
3905 /* Returns the tree that does the intrinsic invocation.
3906
3907    Note: this function applies only to intrinsics returning
3908    CHARACTER*1 or non-CHARACTER results, and to intrinsic
3909    subroutines.  */
3910
3911 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3912 static tree
3913 ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
3914                         ffebld dest, bool *dest_used)
3915 {
3916   tree expr_tree;
3917   tree saved_expr1;             /* For those who need it. */
3918   tree saved_expr2;             /* For those who need it. */
3919   ffeinfoBasictype bt;
3920   ffeinfoKindtype kt;
3921   tree tree_type;
3922   tree arg1_type;
3923   tree real_type;               /* REAL type corresponding to COMPLEX. */
3924   tree tempvar;
3925   ffebld list = ffebld_right (expr);    /* List of (some) args. */
3926   ffebld arg1;                  /* For handy reference. */
3927   ffebld arg2;
3928   ffebld arg3;
3929   ffeintrinImp codegen_imp;
3930   ffecomGfrt gfrt;
3931
3932   assert (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER);
3933
3934   if (dest_used != NULL)
3935     *dest_used = FALSE;
3936
3937   bt = ffeinfo_basictype (ffebld_info (expr));
3938   kt = ffeinfo_kindtype (ffebld_info (expr));
3939   tree_type = ffecom_tree_type[bt][kt];
3940
3941   if (list != NULL)
3942     {
3943       arg1 = ffebld_head (list);
3944       if (arg1 != NULL && ffebld_op (arg1) == FFEBLD_opANY)
3945         return error_mark_node;
3946       if ((list = ffebld_trail (list)) != NULL)
3947         {
3948           arg2 = ffebld_head (list);
3949           if (arg2 != NULL && ffebld_op (arg2) == FFEBLD_opANY)
3950             return error_mark_node;
3951           if ((list = ffebld_trail (list)) != NULL)
3952             {
3953               arg3 = ffebld_head (list);
3954               if (arg3 != NULL && ffebld_op (arg3) == FFEBLD_opANY)
3955                 return error_mark_node;
3956             }
3957           else
3958             arg3 = NULL;
3959         }
3960       else
3961         arg2 = arg3 = NULL;
3962     }
3963   else
3964     arg1 = arg2 = arg3 = NULL;
3965
3966   /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
3967      args.  This is used by the MAX/MIN expansions. */
3968
3969   if (arg1 != NULL)
3970     arg1_type = ffecom_tree_type
3971       [ffeinfo_basictype (ffebld_info (arg1))]
3972       [ffeinfo_kindtype (ffebld_info (arg1))];
3973   else
3974     arg1_type = NULL_TREE;      /* Really not needed, but might catch bugs
3975                                    here. */
3976
3977   /* There are several ways for each of the cases in the following switch
3978      statements to exit (from simplest to use to most complicated):
3979
3980      break;  (when expr_tree == NULL)
3981
3982      A standard call is made to the specific intrinsic just as if it had been
3983      passed in as a dummy procedure and called as any old procedure.  This
3984      method can produce slower code but in some cases it's the easiest way for
3985      now.  However, if a (presumably faster) direct call is available,
3986      that is used, so this is the easiest way in many more cases now.
3987
3988      gfrt = FFECOM_gfrtWHATEVER;
3989      break;
3990
3991      gfrt contains the gfrt index of a library function to call, passing the
3992      argument(s) by value rather than by reference.  Used when a more
3993      careful choice of library function is needed than that provided
3994      by the vanilla `break;'.
3995
3996      return expr_tree;
3997
3998      The expr_tree has been completely set up and is ready to be returned
3999      as is.  No further actions are taken.  Use this when the tree is not
4000      in the simple form for one of the arity_n labels.   */
4001
4002   /* For info on how the switch statement cases were written, see the files
4003      enclosed in comments below the switch statement. */
4004
4005   codegen_imp = ffebld_symter_implementation (ffebld_left (expr));
4006   gfrt = ffeintrin_gfrt_direct (codegen_imp);
4007   if (gfrt == FFECOM_gfrt)
4008     gfrt = ffeintrin_gfrt_indirect (codegen_imp);
4009
4010   switch (codegen_imp)
4011     {
4012     case FFEINTRIN_impABS:
4013     case FFEINTRIN_impCABS:
4014     case FFEINTRIN_impCDABS:
4015     case FFEINTRIN_impDABS:
4016     case FFEINTRIN_impIABS:
4017       if (ffeinfo_basictype (ffebld_info (arg1))
4018           == FFEINFO_basictypeCOMPLEX)
4019         {
4020           if (kt == FFEINFO_kindtypeREAL1)
4021             gfrt = FFECOM_gfrtCABS;
4022           else if (kt == FFEINFO_kindtypeREAL2)
4023             gfrt = FFECOM_gfrtCDABS;
4024           break;
4025         }
4026       return ffecom_1 (ABS_EXPR, tree_type,
4027                        convert (tree_type, ffecom_expr (arg1)));
4028
4029     case FFEINTRIN_impACOS:
4030     case FFEINTRIN_impDACOS:
4031       break;
4032
4033     case FFEINTRIN_impAIMAG:
4034     case FFEINTRIN_impDIMAG:
4035     case FFEINTRIN_impIMAGPART:
4036       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
4037         arg1_type = TREE_TYPE (arg1_type);
4038       else
4039         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
4040
4041       return
4042         convert (tree_type,
4043                  ffecom_1 (IMAGPART_EXPR, arg1_type,
4044                            ffecom_expr (arg1)));
4045
4046     case FFEINTRIN_impAINT:
4047     case FFEINTRIN_impDINT:
4048 #if 0
4049       /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg.  */
4050       return ffecom_1 (FIX_TRUNC_EXPR, tree_type, ffecom_expr (arg1));
4051 #else /* in the meantime, must use floor to avoid range problems with ints */
4052       /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
4053       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4054       return
4055         convert (tree_type,
4056                  ffecom_3 (COND_EXPR, double_type_node,
4057                            ffecom_truth_value
4058                            (ffecom_2 (GE_EXPR, integer_type_node,
4059                                       saved_expr1,
4060                                       convert (arg1_type,
4061                                                ffecom_float_zero_))),
4062                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4063                                              build_tree_list (NULL_TREE,
4064                                                   convert (double_type_node,
4065                                                            saved_expr1)),
4066                                              NULL_TREE),
4067                            ffecom_1 (NEGATE_EXPR, double_type_node,
4068                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4069                                                  build_tree_list (NULL_TREE,
4070                                                   convert (double_type_node,
4071                                                       ffecom_1 (NEGATE_EXPR,
4072                                                                 arg1_type,
4073                                                                saved_expr1))),
4074                                                        NULL_TREE)
4075                                      ))
4076                  );
4077 #endif
4078
4079     case FFEINTRIN_impANINT:
4080     case FFEINTRIN_impDNINT:
4081 #if 0                           /* This way of doing it won't handle real
4082                                    numbers of large magnitudes. */
4083       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4084       expr_tree = convert (tree_type,
4085                            convert (integer_type_node,
4086                                     ffecom_3 (COND_EXPR, tree_type,
4087                                               ffecom_truth_value
4088                                               (ffecom_2 (GE_EXPR,
4089                                                          integer_type_node,
4090                                                          saved_expr1,
4091                                                        ffecom_float_zero_)),
4092                                               ffecom_2 (PLUS_EXPR,
4093                                                         tree_type,
4094                                                         saved_expr1,
4095                                                         ffecom_float_half_),
4096                                               ffecom_2 (MINUS_EXPR,
4097                                                         tree_type,
4098                                                         saved_expr1,
4099                                                      ffecom_float_half_))));
4100       return expr_tree;
4101 #else /* So we instead call floor. */
4102       /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
4103       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4104       return
4105         convert (tree_type,
4106                  ffecom_3 (COND_EXPR, double_type_node,
4107                            ffecom_truth_value
4108                            (ffecom_2 (GE_EXPR, integer_type_node,
4109                                       saved_expr1,
4110                                       convert (arg1_type,
4111                                                ffecom_float_zero_))),
4112                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4113                                              build_tree_list (NULL_TREE,
4114                                                   convert (double_type_node,
4115                                                            ffecom_2 (PLUS_EXPR,
4116                                                                      arg1_type,
4117                                                                      saved_expr1,
4118                                                                      convert (arg1_type,
4119                                                                               ffecom_float_half_)))),
4120                                              NULL_TREE),
4121                            ffecom_1 (NEGATE_EXPR, double_type_node,
4122                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4123                                                        build_tree_list (NULL_TREE,
4124                                                                         convert (double_type_node,
4125                                                                                  ffecom_2 (MINUS_EXPR,
4126                                                                                            arg1_type,
4127                                                                                            convert (arg1_type,
4128                                                                                                     ffecom_float_half_),
4129                                                                                            saved_expr1))),
4130                                                        NULL_TREE))
4131                            )
4132                  );
4133 #endif
4134
4135     case FFEINTRIN_impASIN:
4136     case FFEINTRIN_impDASIN:
4137     case FFEINTRIN_impATAN:
4138     case FFEINTRIN_impDATAN:
4139     case FFEINTRIN_impATAN2:
4140     case FFEINTRIN_impDATAN2:
4141       break;
4142
4143     case FFEINTRIN_impCHAR:
4144     case FFEINTRIN_impACHAR:
4145 #ifdef HOHO
4146       tempvar = ffecom_make_tempvar (char_type_node, 1, -1);
4147 #else
4148       tempvar = ffebld_nonter_hook (expr);
4149       assert (tempvar);
4150 #endif
4151       {
4152         tree tmv = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar)));
4153
4154         expr_tree = ffecom_modify (tmv,
4155                                    ffecom_2 (ARRAY_REF, tmv, tempvar,
4156                                              integer_one_node),
4157                                    convert (tmv, ffecom_expr (arg1)));
4158       }
4159       expr_tree = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar),
4160                             expr_tree,
4161                             tempvar);
4162       expr_tree = ffecom_1 (ADDR_EXPR,
4163                             build_pointer_type (TREE_TYPE (expr_tree)),
4164                             expr_tree);
4165       return expr_tree;
4166
4167     case FFEINTRIN_impCMPLX:
4168     case FFEINTRIN_impDCMPLX:
4169       if (arg2 == NULL)
4170         return
4171           convert (tree_type, ffecom_expr (arg1));
4172
4173       real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4174       return
4175         ffecom_2 (COMPLEX_EXPR, tree_type,
4176                   convert (real_type, ffecom_expr (arg1)),
4177                   convert (real_type,
4178                            ffecom_expr (arg2)));
4179
4180     case FFEINTRIN_impCOMPLEX:
4181       return
4182         ffecom_2 (COMPLEX_EXPR, tree_type,
4183                   ffecom_expr (arg1),
4184                   ffecom_expr (arg2));
4185
4186     case FFEINTRIN_impCONJG:
4187     case FFEINTRIN_impDCONJG:
4188       {
4189         tree arg1_tree;
4190
4191         real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4192         arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4193         return
4194           ffecom_2 (COMPLEX_EXPR, tree_type,
4195                     ffecom_1 (REALPART_EXPR, real_type, arg1_tree),
4196                     ffecom_1 (NEGATE_EXPR, real_type,
4197                               ffecom_1 (IMAGPART_EXPR, real_type, arg1_tree)));
4198       }
4199
4200     case FFEINTRIN_impCOS:
4201     case FFEINTRIN_impCCOS:
4202     case FFEINTRIN_impCDCOS:
4203     case FFEINTRIN_impDCOS:
4204       if (bt == FFEINFO_basictypeCOMPLEX)
4205         {
4206           if (kt == FFEINFO_kindtypeREAL1)
4207             gfrt = FFECOM_gfrtCCOS;     /* Overlapping result okay. */
4208           else if (kt == FFEINFO_kindtypeREAL2)
4209             gfrt = FFECOM_gfrtCDCOS;    /* Overlapping result okay. */
4210         }
4211       break;
4212
4213     case FFEINTRIN_impCOSH:
4214     case FFEINTRIN_impDCOSH:
4215       break;
4216
4217     case FFEINTRIN_impDBLE:
4218     case FFEINTRIN_impDFLOAT:
4219     case FFEINTRIN_impDREAL:
4220     case FFEINTRIN_impFLOAT:
4221     case FFEINTRIN_impIDINT:
4222     case FFEINTRIN_impIFIX:
4223     case FFEINTRIN_impINT2:
4224     case FFEINTRIN_impINT8:
4225     case FFEINTRIN_impINT:
4226     case FFEINTRIN_impLONG:
4227     case FFEINTRIN_impREAL:
4228     case FFEINTRIN_impSHORT:
4229     case FFEINTRIN_impSNGL:
4230       return convert (tree_type, ffecom_expr (arg1));
4231
4232     case FFEINTRIN_impDIM:
4233     case FFEINTRIN_impDDIM:
4234     case FFEINTRIN_impIDIM:
4235       saved_expr1 = ffecom_save_tree (convert (tree_type,
4236                                                ffecom_expr (arg1)));
4237       saved_expr2 = ffecom_save_tree (convert (tree_type,
4238                                                ffecom_expr (arg2)));
4239       return
4240         ffecom_3 (COND_EXPR, tree_type,
4241                   ffecom_truth_value
4242                   (ffecom_2 (GT_EXPR, integer_type_node,
4243                              saved_expr1,
4244                              saved_expr2)),
4245                   ffecom_2 (MINUS_EXPR, tree_type,
4246                             saved_expr1,
4247                             saved_expr2),
4248                   convert (tree_type, ffecom_float_zero_));
4249
4250     case FFEINTRIN_impDPROD:
4251       return
4252         ffecom_2 (MULT_EXPR, tree_type,
4253                   convert (tree_type, ffecom_expr (arg1)),
4254                   convert (tree_type, ffecom_expr (arg2)));
4255
4256     case FFEINTRIN_impEXP:
4257     case FFEINTRIN_impCDEXP:
4258     case FFEINTRIN_impCEXP:
4259     case FFEINTRIN_impDEXP:
4260       if (bt == FFEINFO_basictypeCOMPLEX)
4261         {
4262           if (kt == FFEINFO_kindtypeREAL1)
4263             gfrt = FFECOM_gfrtCEXP;     /* Overlapping result okay. */
4264           else if (kt == FFEINFO_kindtypeREAL2)
4265             gfrt = FFECOM_gfrtCDEXP;    /* Overlapping result okay. */
4266         }
4267       break;
4268
4269     case FFEINTRIN_impICHAR:
4270     case FFEINTRIN_impIACHAR:
4271 #if 0                           /* The simple approach. */
4272       ffecom_char_args_ (&expr_tree, &saved_expr1 /* Ignored */ , arg1);
4273       expr_tree
4274         = ffecom_1 (INDIRECT_REF,
4275                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4276                     expr_tree);
4277       expr_tree
4278         = ffecom_2 (ARRAY_REF,
4279                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4280                     expr_tree,
4281                     integer_one_node);
4282       return convert (tree_type, expr_tree);
4283 #else /* The more interesting (and more optimal) approach. */
4284       expr_tree = ffecom_intrinsic_ichar_ (tree_type, arg1, &saved_expr1);
4285       expr_tree = ffecom_3 (COND_EXPR, tree_type,
4286                             saved_expr1,
4287                             expr_tree,
4288                             convert (tree_type, integer_zero_node));
4289       return expr_tree;
4290 #endif
4291
4292     case FFEINTRIN_impINDEX:
4293       break;
4294
4295     case FFEINTRIN_impLEN:
4296 #if 0
4297       break;                                    /* The simple approach. */
4298 #else
4299       return ffecom_intrinsic_len_ (arg1);      /* The more optimal approach. */
4300 #endif
4301
4302     case FFEINTRIN_impLGE:
4303     case FFEINTRIN_impLGT:
4304     case FFEINTRIN_impLLE:
4305     case FFEINTRIN_impLLT:
4306       break;
4307
4308     case FFEINTRIN_impLOG:
4309     case FFEINTRIN_impALOG:
4310     case FFEINTRIN_impCDLOG:
4311     case FFEINTRIN_impCLOG:
4312     case FFEINTRIN_impDLOG:
4313       if (bt == FFEINFO_basictypeCOMPLEX)
4314         {
4315           if (kt == FFEINFO_kindtypeREAL1)
4316             gfrt = FFECOM_gfrtCLOG;     /* Overlapping result okay. */
4317           else if (kt == FFEINFO_kindtypeREAL2)
4318             gfrt = FFECOM_gfrtCDLOG;    /* Overlapping result okay. */
4319         }
4320       break;
4321
4322     case FFEINTRIN_impLOG10:
4323     case FFEINTRIN_impALOG10:
4324     case FFEINTRIN_impDLOG10:
4325       if (gfrt != FFECOM_gfrt)
4326         break;  /* Already picked one, stick with it. */
4327
4328       if (kt == FFEINFO_kindtypeREAL1)
4329         gfrt = FFECOM_gfrtALOG10;
4330       else if (kt == FFEINFO_kindtypeREAL2)
4331         gfrt = FFECOM_gfrtDLOG10;
4332       break;
4333
4334     case FFEINTRIN_impMAX:
4335     case FFEINTRIN_impAMAX0:
4336     case FFEINTRIN_impAMAX1:
4337     case FFEINTRIN_impDMAX1:
4338     case FFEINTRIN_impMAX0:
4339     case FFEINTRIN_impMAX1:
4340       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4341         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4342       else
4343         arg1_type = tree_type;
4344       expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4345                             convert (arg1_type, ffecom_expr (arg1)),
4346                             convert (arg1_type, ffecom_expr (arg2)));
4347       for (; list != NULL; list = ffebld_trail (list))
4348         {
4349           if ((ffebld_head (list) == NULL)
4350               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4351             continue;
4352           expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4353                                 expr_tree,
4354                                 convert (arg1_type,
4355                                          ffecom_expr (ffebld_head (list))));
4356         }
4357       return convert (tree_type, expr_tree);
4358
4359     case FFEINTRIN_impMIN:
4360     case FFEINTRIN_impAMIN0:
4361     case FFEINTRIN_impAMIN1:
4362     case FFEINTRIN_impDMIN1:
4363     case FFEINTRIN_impMIN0:
4364     case FFEINTRIN_impMIN1:
4365       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4366         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4367       else
4368         arg1_type = tree_type;
4369       expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4370                             convert (arg1_type, ffecom_expr (arg1)),
4371                             convert (arg1_type, ffecom_expr (arg2)));
4372       for (; list != NULL; list = ffebld_trail (list))
4373         {
4374           if ((ffebld_head (list) == NULL)
4375               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4376             continue;
4377           expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4378                                 expr_tree,
4379                                 convert (arg1_type,
4380                                          ffecom_expr (ffebld_head (list))));
4381         }
4382       return convert (tree_type, expr_tree);
4383
4384     case FFEINTRIN_impMOD:
4385     case FFEINTRIN_impAMOD:
4386     case FFEINTRIN_impDMOD:
4387       if (bt != FFEINFO_basictypeREAL)
4388         return ffecom_2 (TRUNC_MOD_EXPR, tree_type,
4389                          convert (tree_type, ffecom_expr (arg1)),
4390                          convert (tree_type, ffecom_expr (arg2)));
4391
4392       if (kt == FFEINFO_kindtypeREAL1)
4393         gfrt = FFECOM_gfrtAMOD;
4394       else if (kt == FFEINFO_kindtypeREAL2)
4395         gfrt = FFECOM_gfrtDMOD;
4396       break;
4397
4398     case FFEINTRIN_impNINT:
4399     case FFEINTRIN_impIDNINT:
4400 #if 0
4401       /* ~~Ideally FIX_ROUND_EXPR would be implemented, but it ain't yet.  */
4402       return ffecom_1 (FIX_ROUND_EXPR, tree_type, ffecom_expr (arg1));
4403 #else
4404       /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
4405       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4406       return
4407         convert (ffecom_integer_type_node,
4408                  ffecom_3 (COND_EXPR, arg1_type,
4409                            ffecom_truth_value
4410                            (ffecom_2 (GE_EXPR, integer_type_node,
4411                                       saved_expr1,
4412                                       convert (arg1_type,
4413                                                ffecom_float_zero_))),
4414                            ffecom_2 (PLUS_EXPR, arg1_type,
4415                                      saved_expr1,
4416                                      convert (arg1_type,
4417                                               ffecom_float_half_)),
4418                            ffecom_2 (MINUS_EXPR, arg1_type,
4419                                      saved_expr1,
4420                                      convert (arg1_type,
4421                                               ffecom_float_half_))));
4422 #endif
4423
4424     case FFEINTRIN_impSIGN:
4425     case FFEINTRIN_impDSIGN:
4426     case FFEINTRIN_impISIGN:
4427       {
4428         tree arg2_tree = ffecom_expr (arg2);
4429
4430         saved_expr1
4431           = ffecom_save_tree
4432           (ffecom_1 (ABS_EXPR, tree_type,
4433                      convert (tree_type,
4434                               ffecom_expr (arg1))));
4435         expr_tree
4436           = ffecom_3 (COND_EXPR, tree_type,
4437                       ffecom_truth_value
4438                       (ffecom_2 (GE_EXPR, integer_type_node,
4439                                  arg2_tree,
4440                                  convert (TREE_TYPE (arg2_tree),
4441                                           integer_zero_node))),
4442                       saved_expr1,
4443                       ffecom_1 (NEGATE_EXPR, tree_type, saved_expr1));
4444         /* Make sure SAVE_EXPRs get referenced early enough. */
4445         expr_tree
4446           = ffecom_2 (COMPOUND_EXPR, tree_type,
4447                       convert (void_type_node, saved_expr1),
4448                       expr_tree);
4449       }
4450       return expr_tree;
4451
4452     case FFEINTRIN_impSIN:
4453     case FFEINTRIN_impCDSIN:
4454     case FFEINTRIN_impCSIN:
4455     case FFEINTRIN_impDSIN:
4456       if (bt == FFEINFO_basictypeCOMPLEX)
4457         {
4458           if (kt == FFEINFO_kindtypeREAL1)
4459             gfrt = FFECOM_gfrtCSIN;     /* Overlapping result okay. */
4460           else if (kt == FFEINFO_kindtypeREAL2)
4461             gfrt = FFECOM_gfrtCDSIN;    /* Overlapping result okay. */
4462         }
4463       break;
4464
4465     case FFEINTRIN_impSINH:
4466     case FFEINTRIN_impDSINH:
4467       break;
4468
4469     case FFEINTRIN_impSQRT:
4470     case FFEINTRIN_impCDSQRT:
4471     case FFEINTRIN_impCSQRT:
4472     case FFEINTRIN_impDSQRT:
4473       if (bt == FFEINFO_basictypeCOMPLEX)
4474         {
4475           if (kt == FFEINFO_kindtypeREAL1)
4476             gfrt = FFECOM_gfrtCSQRT;    /* Overlapping result okay. */
4477           else if (kt == FFEINFO_kindtypeREAL2)
4478             gfrt = FFECOM_gfrtCDSQRT;   /* Overlapping result okay. */
4479         }
4480       break;
4481
4482     case FFEINTRIN_impTAN:
4483     case FFEINTRIN_impDTAN:
4484     case FFEINTRIN_impTANH:
4485     case FFEINTRIN_impDTANH:
4486       break;
4487
4488     case FFEINTRIN_impREALPART:
4489       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
4490         arg1_type = TREE_TYPE (arg1_type);
4491       else
4492         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
4493
4494       return
4495         convert (tree_type,
4496                  ffecom_1 (REALPART_EXPR, arg1_type,
4497                            ffecom_expr (arg1)));
4498
4499     case FFEINTRIN_impIAND:
4500     case FFEINTRIN_impAND:
4501       return ffecom_2 (BIT_AND_EXPR, tree_type,
4502                        convert (tree_type,
4503                                 ffecom_expr (arg1)),
4504                        convert (tree_type,
4505                                 ffecom_expr (arg2)));
4506
4507     case FFEINTRIN_impIOR:
4508     case FFEINTRIN_impOR:
4509       return ffecom_2 (BIT_IOR_EXPR, tree_type,
4510                        convert (tree_type,
4511                                 ffecom_expr (arg1)),
4512                        convert (tree_type,
4513                                 ffecom_expr (arg2)));
4514
4515     case FFEINTRIN_impIEOR:
4516     case FFEINTRIN_impXOR:
4517       return ffecom_2 (BIT_XOR_EXPR, tree_type,
4518                        convert (tree_type,
4519                                 ffecom_expr (arg1)),
4520                        convert (tree_type,
4521                                 ffecom_expr (arg2)));
4522
4523     case FFEINTRIN_impLSHIFT:
4524       return ffecom_2 (LSHIFT_EXPR, tree_type,
4525                        ffecom_expr (arg1),
4526                        convert (integer_type_node,
4527                                 ffecom_expr (arg2)));
4528
4529     case FFEINTRIN_impRSHIFT:
4530       return ffecom_2 (RSHIFT_EXPR, tree_type,
4531                        ffecom_expr (arg1),
4532                        convert (integer_type_node,
4533                                 ffecom_expr (arg2)));
4534
4535     case FFEINTRIN_impNOT:
4536       return ffecom_1 (BIT_NOT_EXPR, tree_type, ffecom_expr (arg1));
4537
4538     case FFEINTRIN_impBIT_SIZE:
4539       return convert (tree_type, TYPE_SIZE (arg1_type));
4540
4541     case FFEINTRIN_impBTEST:
4542       {
4543         ffetargetLogical1 true;
4544         ffetargetLogical1 false;
4545         tree true_tree;
4546         tree false_tree;
4547
4548         ffetarget_logical1 (&true, TRUE);
4549         ffetarget_logical1 (&false, FALSE);
4550         if (true == 1)
4551           true_tree = convert (tree_type, integer_one_node);
4552         else
4553           true_tree = convert (tree_type, build_int_2 (true, 0));
4554         if (false == 0)
4555           false_tree = convert (tree_type, integer_zero_node);
4556         else
4557           false_tree = convert (tree_type, build_int_2 (false, 0));
4558
4559         return
4560           ffecom_3 (COND_EXPR, tree_type,
4561                     ffecom_truth_value
4562                     (ffecom_2 (EQ_EXPR, integer_type_node,
4563                                ffecom_2 (BIT_AND_EXPR, arg1_type,
4564                                          ffecom_expr (arg1),
4565                                          ffecom_2 (LSHIFT_EXPR, arg1_type,
4566                                                    convert (arg1_type,
4567                                                           integer_one_node),
4568                                                    convert (integer_type_node,
4569                                                             ffecom_expr (arg2)))),
4570                                convert (arg1_type,
4571                                         integer_zero_node))),
4572                     false_tree,
4573                     true_tree);
4574       }
4575
4576     case FFEINTRIN_impIBCLR:
4577       return
4578         ffecom_2 (BIT_AND_EXPR, tree_type,
4579                   ffecom_expr (arg1),
4580                   ffecom_1 (BIT_NOT_EXPR, tree_type,
4581                             ffecom_2 (LSHIFT_EXPR, tree_type,
4582                                       convert (tree_type,
4583                                                integer_one_node),
4584                                       convert (integer_type_node,
4585                                                ffecom_expr (arg2)))));
4586
4587     case FFEINTRIN_impIBITS:
4588       {
4589         tree arg3_tree = ffecom_save_tree (convert (integer_type_node,
4590                                                     ffecom_expr (arg3)));
4591         tree uns_type
4592         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4593
4594         expr_tree
4595           = ffecom_2 (BIT_AND_EXPR, tree_type,
4596                       ffecom_2 (RSHIFT_EXPR, tree_type,
4597                                 ffecom_expr (arg1),
4598                                 convert (integer_type_node,
4599                                          ffecom_expr (arg2))),
4600                       convert (tree_type,
4601                                ffecom_2 (RSHIFT_EXPR, uns_type,
4602                                          ffecom_1 (BIT_NOT_EXPR,
4603                                                    uns_type,
4604                                                    convert (uns_type,
4605                                                         integer_zero_node)),
4606                                          ffecom_2 (MINUS_EXPR,
4607                                                    integer_type_node,
4608                                                    TYPE_SIZE (uns_type),
4609                                                    arg3_tree))));
4610 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4611         expr_tree
4612           = ffecom_3 (COND_EXPR, tree_type,
4613                       ffecom_truth_value
4614                       (ffecom_2 (NE_EXPR, integer_type_node,
4615                                  arg3_tree,
4616                                  integer_zero_node)),
4617                       expr_tree,
4618                       convert (tree_type, integer_zero_node));
4619 #endif
4620       }
4621       return expr_tree;
4622
4623     case FFEINTRIN_impIBSET:
4624       return
4625         ffecom_2 (BIT_IOR_EXPR, tree_type,
4626                   ffecom_expr (arg1),
4627                   ffecom_2 (LSHIFT_EXPR, tree_type,
4628                             convert (tree_type, integer_one_node),
4629                             convert (integer_type_node,
4630                                      ffecom_expr (arg2))));
4631
4632     case FFEINTRIN_impISHFT:
4633       {
4634         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4635         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4636                                                     ffecom_expr (arg2)));
4637         tree uns_type
4638         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4639
4640         expr_tree
4641           = ffecom_3 (COND_EXPR, tree_type,
4642                       ffecom_truth_value
4643                       (ffecom_2 (GE_EXPR, integer_type_node,
4644                                  arg2_tree,
4645                                  integer_zero_node)),
4646                       ffecom_2 (LSHIFT_EXPR, tree_type,
4647                                 arg1_tree,
4648                                 arg2_tree),
4649                       convert (tree_type,
4650                                ffecom_2 (RSHIFT_EXPR, uns_type,
4651                                          convert (uns_type, arg1_tree),
4652                                          ffecom_1 (NEGATE_EXPR,
4653                                                    integer_type_node,
4654                                                    arg2_tree))));
4655 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4656         expr_tree
4657           = ffecom_3 (COND_EXPR, tree_type,
4658                       ffecom_truth_value
4659                       (ffecom_2 (NE_EXPR, integer_type_node,
4660                                  arg2_tree,
4661                                  TYPE_SIZE (uns_type))),
4662                       expr_tree,
4663                       convert (tree_type, integer_zero_node));
4664 #endif
4665         /* Make sure SAVE_EXPRs get referenced early enough. */
4666         expr_tree
4667           = ffecom_2 (COMPOUND_EXPR, tree_type,
4668                       convert (void_type_node, arg1_tree),
4669                       ffecom_2 (COMPOUND_EXPR, tree_type,
4670                                 convert (void_type_node, arg2_tree),
4671                                 expr_tree));
4672       }
4673       return expr_tree;
4674
4675     case FFEINTRIN_impISHFTC:
4676       {
4677         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4678         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4679                                                     ffecom_expr (arg2)));
4680         tree arg3_tree = (arg3 == NULL) ? TYPE_SIZE (tree_type)
4681         : ffecom_save_tree (convert (integer_type_node, ffecom_expr (arg3)));
4682         tree shift_neg;
4683         tree shift_pos;
4684         tree mask_arg1;
4685         tree masked_arg1;
4686         tree uns_type
4687         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4688
4689         mask_arg1
4690           = ffecom_2 (LSHIFT_EXPR, tree_type,
4691                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4692                                 convert (tree_type, integer_zero_node)),
4693                       arg3_tree);
4694 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4695         mask_arg1
4696           = ffecom_3 (COND_EXPR, tree_type,
4697                       ffecom_truth_value
4698                       (ffecom_2 (NE_EXPR, integer_type_node,
4699                                  arg3_tree,
4700                                  TYPE_SIZE (uns_type))),
4701                       mask_arg1,
4702                       convert (tree_type, integer_zero_node));
4703 #endif
4704         mask_arg1 = ffecom_save_tree (mask_arg1);
4705         masked_arg1
4706           = ffecom_2 (BIT_AND_EXPR, tree_type,
4707                       arg1_tree,
4708                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4709                                 mask_arg1));
4710         masked_arg1 = ffecom_save_tree (masked_arg1);
4711         shift_neg
4712           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4713                       convert (tree_type,
4714                                ffecom_2 (RSHIFT_EXPR, uns_type,
4715                                          convert (uns_type, masked_arg1),
4716                                          ffecom_1 (NEGATE_EXPR,
4717                                                    integer_type_node,
4718                                                    arg2_tree))),
4719                       ffecom_2 (LSHIFT_EXPR, tree_type,
4720                                 arg1_tree,
4721                                 ffecom_2 (PLUS_EXPR, integer_type_node,
4722                                           arg2_tree,
4723                                           arg3_tree)));
4724         shift_pos
4725           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4726                       ffecom_2 (LSHIFT_EXPR, tree_type,
4727                                 arg1_tree,
4728                                 arg2_tree),
4729                       convert (tree_type,
4730                                ffecom_2 (RSHIFT_EXPR, uns_type,
4731                                          convert (uns_type, masked_arg1),
4732                                          ffecom_2 (MINUS_EXPR,
4733                                                    integer_type_node,
4734                                                    arg3_tree,
4735                                                    arg2_tree))));
4736         expr_tree
4737           = ffecom_3 (COND_EXPR, tree_type,
4738                       ffecom_truth_value
4739                       (ffecom_2 (LT_EXPR, integer_type_node,
4740                                  arg2_tree,
4741                                  integer_zero_node)),
4742                       shift_neg,
4743                       shift_pos);
4744         expr_tree
4745           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4746                       ffecom_2 (BIT_AND_EXPR, tree_type,
4747                                 mask_arg1,
4748                                 arg1_tree),
4749                       ffecom_2 (BIT_AND_EXPR, tree_type,
4750                                 ffecom_1 (BIT_NOT_EXPR, tree_type,
4751                                           mask_arg1),
4752                                 expr_tree));
4753         expr_tree
4754           = ffecom_3 (COND_EXPR, tree_type,
4755                       ffecom_truth_value
4756                       (ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
4757                                  ffecom_2 (EQ_EXPR, integer_type_node,
4758                                            ffecom_1 (ABS_EXPR,
4759                                                      integer_type_node,
4760                                                      arg2_tree),
4761                                            arg3_tree),
4762                                  ffecom_2 (EQ_EXPR, integer_type_node,
4763                                            arg2_tree,
4764                                            integer_zero_node))),
4765                       arg1_tree,
4766                       expr_tree);
4767         /* Make sure SAVE_EXPRs get referenced early enough. */
4768         expr_tree
4769           = ffecom_2 (COMPOUND_EXPR, tree_type,
4770                       convert (void_type_node, arg1_tree),
4771                       ffecom_2 (COMPOUND_EXPR, tree_type,
4772                                 convert (void_type_node, arg2_tree),
4773                                 ffecom_2 (COMPOUND_EXPR, tree_type,
4774                                           convert (void_type_node,
4775                                                    mask_arg1),
4776                                           ffecom_2 (COMPOUND_EXPR, tree_type,
4777                                                     convert (void_type_node,
4778                                                              masked_arg1),
4779                                                     expr_tree))));
4780         expr_tree
4781           = ffecom_2 (COMPOUND_EXPR, tree_type,
4782                       convert (void_type_node,
4783                                arg3_tree),
4784                       expr_tree);
4785       }
4786       return expr_tree;
4787
4788     case FFEINTRIN_impLOC:
4789       {
4790         tree arg1_tree = ffecom_expr (arg1);
4791
4792         expr_tree
4793           = convert (tree_type,
4794                      ffecom_1 (ADDR_EXPR,
4795                                build_pointer_type (TREE_TYPE (arg1_tree)),
4796                                arg1_tree));
4797       }
4798       return expr_tree;
4799
4800     case FFEINTRIN_impMVBITS:
4801       {
4802         tree arg1_tree;
4803         tree arg2_tree;
4804         tree arg3_tree;
4805         ffebld arg4 = ffebld_head (ffebld_trail (list));
4806         tree arg4_tree;
4807         tree arg4_type;
4808         ffebld arg5 = ffebld_head (ffebld_trail (ffebld_trail (list)));
4809         tree arg5_tree;
4810         tree prep_arg1;
4811         tree prep_arg4;
4812         tree arg5_plus_arg3;
4813
4814         arg2_tree = convert (integer_type_node,
4815                              ffecom_expr (arg2));
4816         arg3_tree = ffecom_save_tree (convert (integer_type_node,
4817                                                ffecom_expr (arg3)));
4818         arg4_tree = ffecom_expr_rw (NULL_TREE, arg4);
4819         arg4_type = TREE_TYPE (arg4_tree);
4820
4821         arg1_tree = ffecom_save_tree (convert (arg4_type,
4822                                                ffecom_expr (arg1)));
4823
4824         arg5_tree = ffecom_save_tree (convert (integer_type_node,
4825                                                ffecom_expr (arg5)));
4826
4827         prep_arg1
4828           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4829                       ffecom_2 (BIT_AND_EXPR, arg4_type,
4830                                 ffecom_2 (RSHIFT_EXPR, arg4_type,
4831                                           arg1_tree,
4832                                           arg2_tree),
4833                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4834                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4835                                                     ffecom_1 (BIT_NOT_EXPR,
4836                                                               arg4_type,
4837                                                               convert
4838                                                               (arg4_type,
4839                                                         integer_zero_node)),
4840                                                     arg3_tree))),
4841                       arg5_tree);
4842         arg5_plus_arg3
4843           = ffecom_save_tree (ffecom_2 (PLUS_EXPR, arg4_type,
4844                                         arg5_tree,
4845                                         arg3_tree));
4846         prep_arg4
4847           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4848                       ffecom_1 (BIT_NOT_EXPR, arg4_type,
4849                                 convert (arg4_type,
4850                                          integer_zero_node)),
4851                       arg5_plus_arg3);
4852 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4853         prep_arg4
4854           = ffecom_3 (COND_EXPR, arg4_type,
4855                       ffecom_truth_value
4856                       (ffecom_2 (NE_EXPR, integer_type_node,
4857                                  arg5_plus_arg3,
4858                                  convert (TREE_TYPE (arg5_plus_arg3),
4859                                           TYPE_SIZE (arg4_type)))),
4860                       prep_arg4,
4861                       convert (arg4_type, integer_zero_node));
4862 #endif
4863         prep_arg4
4864           = ffecom_2 (BIT_AND_EXPR, arg4_type,
4865                       arg4_tree,
4866                       ffecom_2 (BIT_IOR_EXPR, arg4_type,
4867                                 prep_arg4,
4868                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4869                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4870                                                     ffecom_1 (BIT_NOT_EXPR,
4871                                                               arg4_type,
4872                                                               convert
4873                                                               (arg4_type,
4874                                                         integer_zero_node)),
4875                                                     arg5_tree))));
4876         prep_arg1
4877           = ffecom_2 (BIT_IOR_EXPR, arg4_type,
4878                       prep_arg1,
4879                       prep_arg4);
4880 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4881         prep_arg1
4882           = ffecom_3 (COND_EXPR, arg4_type,
4883                       ffecom_truth_value
4884                       (ffecom_2 (NE_EXPR, integer_type_node,
4885                                  arg3_tree,
4886                                  convert (TREE_TYPE (arg3_tree),
4887                                           integer_zero_node))),
4888                       prep_arg1,
4889                       arg4_tree);
4890         prep_arg1
4891           = ffecom_3 (COND_EXPR, arg4_type,
4892                       ffecom_truth_value
4893                       (ffecom_2 (NE_EXPR, integer_type_node,
4894                                  arg3_tree,
4895                                  convert (TREE_TYPE (arg3_tree),
4896                                           TYPE_SIZE (arg4_type)))),
4897                       prep_arg1,
4898                       arg1_tree);
4899 #endif
4900         expr_tree
4901           = ffecom_2s (MODIFY_EXPR, void_type_node,
4902                        arg4_tree,
4903                        prep_arg1);
4904         /* Make sure SAVE_EXPRs get referenced early enough. */
4905         expr_tree
4906           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4907                       arg1_tree,
4908                       ffecom_2 (COMPOUND_EXPR, void_type_node,
4909                                 arg3_tree,
4910                                 ffecom_2 (COMPOUND_EXPR, void_type_node,
4911                                           arg5_tree,
4912                                           ffecom_2 (COMPOUND_EXPR, void_type_node,
4913                                                     arg5_plus_arg3,
4914                                                     expr_tree))));
4915         expr_tree
4916           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4917                       arg4_tree,
4918                       expr_tree);
4919
4920       }
4921       return expr_tree;
4922
4923     case FFEINTRIN_impDERF:
4924     case FFEINTRIN_impERF:
4925     case FFEINTRIN_impDERFC:
4926     case FFEINTRIN_impERFC:
4927       break;
4928
4929     case FFEINTRIN_impIARGC:
4930       /* extern int xargc; i__1 = xargc - 1; */
4931       expr_tree = ffecom_2 (MINUS_EXPR, TREE_TYPE (ffecom_tree_xargc_),
4932                             ffecom_tree_xargc_,
4933                             convert (TREE_TYPE (ffecom_tree_xargc_),
4934                                      integer_one_node));
4935       return expr_tree;
4936
4937     case FFEINTRIN_impSIGNAL_func:
4938     case FFEINTRIN_impSIGNAL_subr:
4939       {
4940         tree arg1_tree;
4941         tree arg2_tree;
4942         tree arg3_tree;
4943
4944         arg1_tree = convert (ffecom_f2c_integer_type_node,
4945                              ffecom_expr (arg1));
4946         arg1_tree = ffecom_1 (ADDR_EXPR,
4947                               build_pointer_type (TREE_TYPE (arg1_tree)),
4948                               arg1_tree);
4949
4950         /* Pass procedure as a pointer to it, anything else by value.  */
4951         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4952           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4953         else
4954           arg2_tree = ffecom_ptr_to_expr (arg2);
4955         arg2_tree = convert (TREE_TYPE (null_pointer_node),
4956                              arg2_tree);
4957
4958         if (arg3 != NULL)
4959           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4960         else
4961           arg3_tree = NULL_TREE;
4962
4963         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4964         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4965         TREE_CHAIN (arg1_tree) = arg2_tree;
4966
4967         expr_tree
4968           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4969                           ffecom_gfrt_kindtype (gfrt),
4970                           FALSE,
4971                           ((codegen_imp == FFEINTRIN_impSIGNAL_subr) ?
4972                            NULL_TREE :
4973                            tree_type),
4974                           arg1_tree,
4975                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4976                           ffebld_nonter_hook (expr));
4977
4978         if (arg3_tree != NULL_TREE)
4979           expr_tree
4980             = ffecom_modify (NULL_TREE, arg3_tree,
4981                              convert (TREE_TYPE (arg3_tree),
4982                                       expr_tree));
4983       }
4984       return expr_tree;
4985
4986     case FFEINTRIN_impALARM:
4987       {
4988         tree arg1_tree;
4989         tree arg2_tree;
4990         tree arg3_tree;
4991
4992         arg1_tree = convert (ffecom_f2c_integer_type_node,
4993                              ffecom_expr (arg1));
4994         arg1_tree = ffecom_1 (ADDR_EXPR,
4995                               build_pointer_type (TREE_TYPE (arg1_tree)),
4996                               arg1_tree);
4997
4998         /* Pass procedure as a pointer to it, anything else by value.  */
4999         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
5000           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
5001         else
5002           arg2_tree = ffecom_ptr_to_expr (arg2);
5003         arg2_tree = convert (TREE_TYPE (null_pointer_node),
5004                              arg2_tree);
5005
5006         if (arg3 != NULL)
5007           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5008         else
5009           arg3_tree = NULL_TREE;
5010
5011         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5012         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5013         TREE_CHAIN (arg1_tree) = arg2_tree;
5014
5015         expr_tree
5016           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5017                           ffecom_gfrt_kindtype (gfrt),
5018                           FALSE,
5019                           NULL_TREE,
5020                           arg1_tree,
5021                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5022                           ffebld_nonter_hook (expr));
5023
5024         if (arg3_tree != NULL_TREE)
5025           expr_tree
5026             = ffecom_modify (NULL_TREE, arg3_tree,
5027                              convert (TREE_TYPE (arg3_tree),
5028                                       expr_tree));
5029       }
5030       return expr_tree;
5031
5032     case FFEINTRIN_impCHDIR_subr:
5033     case FFEINTRIN_impFDATE_subr:
5034     case FFEINTRIN_impFGET_subr:
5035     case FFEINTRIN_impFPUT_subr:
5036     case FFEINTRIN_impGETCWD_subr:
5037     case FFEINTRIN_impHOSTNM_subr:
5038     case FFEINTRIN_impSYSTEM_subr:
5039     case FFEINTRIN_impUNLINK_subr:
5040       {
5041         tree arg1_len = integer_zero_node;
5042         tree arg1_tree;
5043         tree arg2_tree;
5044
5045         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5046
5047         if (arg2 != NULL)
5048           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
5049         else
5050           arg2_tree = NULL_TREE;
5051
5052         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5053         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5054         TREE_CHAIN (arg1_tree) = arg1_len;
5055
5056         expr_tree
5057           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5058                           ffecom_gfrt_kindtype (gfrt),
5059                           FALSE,
5060                           NULL_TREE,
5061                           arg1_tree,
5062                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5063                           ffebld_nonter_hook (expr));
5064
5065         if (arg2_tree != NULL_TREE)
5066           expr_tree
5067             = ffecom_modify (NULL_TREE, arg2_tree,
5068                              convert (TREE_TYPE (arg2_tree),
5069                                       expr_tree));
5070       }
5071       return expr_tree;
5072
5073     case FFEINTRIN_impEXIT:
5074       if (arg1 != NULL)
5075         break;
5076
5077       expr_tree = build_tree_list (NULL_TREE,
5078                                    ffecom_1 (ADDR_EXPR,
5079                                              build_pointer_type
5080                                              (ffecom_integer_type_node),
5081                                              integer_zero_node));
5082
5083       return
5084         ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5085                       ffecom_gfrt_kindtype (gfrt),
5086                       FALSE,
5087                       void_type_node,
5088                       expr_tree,
5089                       NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5090                       ffebld_nonter_hook (expr));
5091
5092     case FFEINTRIN_impFLUSH:
5093       if (arg1 == NULL)
5094         gfrt = FFECOM_gfrtFLUSH;
5095       else
5096         gfrt = FFECOM_gfrtFLUSH1;
5097       break;
5098
5099     case FFEINTRIN_impCHMOD_subr:
5100     case FFEINTRIN_impLINK_subr:
5101     case FFEINTRIN_impRENAME_subr:
5102     case FFEINTRIN_impSYMLNK_subr:
5103       {
5104         tree arg1_len = integer_zero_node;
5105         tree arg1_tree;
5106         tree arg2_len = integer_zero_node;
5107         tree arg2_tree;
5108         tree arg3_tree;
5109
5110         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5111         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
5112         if (arg3 != NULL)
5113           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5114         else
5115           arg3_tree = NULL_TREE;
5116
5117         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5118         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5119         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5120         arg2_len = build_tree_list (NULL_TREE, arg2_len);
5121         TREE_CHAIN (arg1_tree) = arg2_tree;
5122         TREE_CHAIN (arg2_tree) = arg1_len;
5123         TREE_CHAIN (arg1_len) = arg2_len;
5124         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5125                                   ffecom_gfrt_kindtype (gfrt),
5126                                   FALSE,
5127                                   NULL_TREE,
5128                                   arg1_tree,
5129                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5130                                   ffebld_nonter_hook (expr));
5131         if (arg3_tree != NULL_TREE)
5132           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5133                                      convert (TREE_TYPE (arg3_tree),
5134                                               expr_tree));
5135       }
5136       return expr_tree;
5137
5138     case FFEINTRIN_impLSTAT_subr:
5139     case FFEINTRIN_impSTAT_subr:
5140       {
5141         tree arg1_len = integer_zero_node;
5142         tree arg1_tree;
5143         tree arg2_tree;
5144         tree arg3_tree;
5145
5146         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5147
5148         arg2_tree = ffecom_ptr_to_expr (arg2);
5149
5150         if (arg3 != NULL)
5151           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5152         else
5153           arg3_tree = NULL_TREE;
5154
5155         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5156         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5157         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5158         TREE_CHAIN (arg1_tree) = arg2_tree;
5159         TREE_CHAIN (arg2_tree) = arg1_len;
5160         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5161                                   ffecom_gfrt_kindtype (gfrt),
5162                                   FALSE,
5163                                   NULL_TREE,
5164                                   arg1_tree,
5165                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5166                                   ffebld_nonter_hook (expr));
5167         if (arg3_tree != NULL_TREE)
5168           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5169                                      convert (TREE_TYPE (arg3_tree),
5170                                               expr_tree));
5171       }
5172       return expr_tree;
5173
5174     case FFEINTRIN_impFGETC_subr:
5175     case FFEINTRIN_impFPUTC_subr:
5176       {
5177         tree arg1_tree;
5178         tree arg2_tree;
5179         tree arg2_len = integer_zero_node;
5180         tree arg3_tree;
5181
5182         arg1_tree = convert (ffecom_f2c_integer_type_node,
5183                              ffecom_expr (arg1));
5184         arg1_tree = ffecom_1 (ADDR_EXPR,
5185                               build_pointer_type (TREE_TYPE (arg1_tree)),
5186                               arg1_tree);
5187
5188         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
5189         arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5190
5191         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5192         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5193         arg2_len = build_tree_list (NULL_TREE, arg2_len);
5194         TREE_CHAIN (arg1_tree) = arg2_tree;
5195         TREE_CHAIN (arg2_tree) = arg2_len;
5196
5197         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5198                                   ffecom_gfrt_kindtype (gfrt),
5199                                   FALSE,
5200                                   NULL_TREE,
5201                                   arg1_tree,
5202                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5203                                   ffebld_nonter_hook (expr));
5204         expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5205                                    convert (TREE_TYPE (arg3_tree),
5206                                             expr_tree));
5207       }
5208       return expr_tree;
5209
5210     case FFEINTRIN_impFSTAT_subr:
5211       {
5212         tree arg1_tree;
5213         tree arg2_tree;
5214         tree arg3_tree;
5215
5216         arg1_tree = convert (ffecom_f2c_integer_type_node,
5217                              ffecom_expr (arg1));
5218         arg1_tree = ffecom_1 (ADDR_EXPR,
5219                               build_pointer_type (TREE_TYPE (arg1_tree)),
5220                               arg1_tree);
5221
5222         arg2_tree = convert (ffecom_f2c_ptr_to_integer_type_node,
5223                              ffecom_ptr_to_expr (arg2));
5224
5225         if (arg3 == NULL)
5226           arg3_tree = NULL_TREE;
5227         else
5228           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5229
5230         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5231         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5232         TREE_CHAIN (arg1_tree) = arg2_tree;
5233         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5234                                   ffecom_gfrt_kindtype (gfrt),
5235                                   FALSE,
5236                                   NULL_TREE,
5237                                   arg1_tree,
5238                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5239                                   ffebld_nonter_hook (expr));
5240         if (arg3_tree != NULL_TREE) {
5241           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5242                                      convert (TREE_TYPE (arg3_tree),
5243                                               expr_tree));
5244         }
5245       }
5246       return expr_tree;
5247
5248     case FFEINTRIN_impKILL_subr:
5249       {
5250         tree arg1_tree;
5251         tree arg2_tree;
5252         tree arg3_tree;
5253
5254         arg1_tree = convert (ffecom_f2c_integer_type_node,
5255                              ffecom_expr (arg1));
5256         arg1_tree = ffecom_1 (ADDR_EXPR,
5257                               build_pointer_type (TREE_TYPE (arg1_tree)),
5258                               arg1_tree);
5259
5260         arg2_tree = convert (ffecom_f2c_integer_type_node,
5261                              ffecom_expr (arg2));
5262         arg2_tree = ffecom_1 (ADDR_EXPR,
5263                               build_pointer_type (TREE_TYPE (arg2_tree)),
5264                               arg2_tree);
5265
5266         if (arg3 == NULL)
5267           arg3_tree = NULL_TREE;
5268         else
5269           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5270
5271         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5272         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5273         TREE_CHAIN (arg1_tree) = arg2_tree;
5274         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5275                                   ffecom_gfrt_kindtype (gfrt),
5276                                   FALSE,
5277                                   NULL_TREE,
5278                                   arg1_tree,
5279                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5280                                   ffebld_nonter_hook (expr));
5281         if (arg3_tree != NULL_TREE) {
5282           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5283                                      convert (TREE_TYPE (arg3_tree),
5284                                               expr_tree));
5285         }
5286       }
5287       return expr_tree;
5288
5289     case FFEINTRIN_impCTIME_subr:
5290     case FFEINTRIN_impTTYNAM_subr:
5291       {
5292         tree arg1_len = integer_zero_node;
5293         tree arg1_tree;
5294         tree arg2_tree;
5295
5296         arg1_tree = ffecom_arg_ptr_to_expr (arg2, &arg1_len);
5297
5298         arg2_tree = convert (((codegen_imp == FFEINTRIN_impCTIME_subr) ?
5299                               ffecom_f2c_longint_type_node :
5300                               ffecom_f2c_integer_type_node),
5301                              ffecom_expr (arg1));
5302         arg2_tree = ffecom_1 (ADDR_EXPR,
5303                               build_pointer_type (TREE_TYPE (arg2_tree)),
5304                               arg2_tree);
5305
5306         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5307         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5308         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5309         TREE_CHAIN (arg1_len) = arg2_tree;
5310         TREE_CHAIN (arg1_tree) = arg1_len;
5311
5312         expr_tree
5313           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5314                           ffecom_gfrt_kindtype (gfrt),
5315                           FALSE,
5316                           NULL_TREE,
5317                           arg1_tree,
5318                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5319                           ffebld_nonter_hook (expr));
5320         TREE_SIDE_EFFECTS (expr_tree) = 1;
5321       }
5322       return expr_tree;
5323
5324     case FFEINTRIN_impIRAND:
5325     case FFEINTRIN_impRAND:
5326       /* Arg defaults to 0 (normal random case) */
5327       {
5328         tree arg1_tree;
5329
5330         if (arg1 == NULL)
5331           arg1_tree = ffecom_integer_zero_node;
5332         else
5333           arg1_tree = ffecom_expr (arg1);
5334         arg1_tree = convert (ffecom_f2c_integer_type_node,
5335                              arg1_tree);
5336         arg1_tree = ffecom_1 (ADDR_EXPR,
5337                               build_pointer_type (TREE_TYPE (arg1_tree)),
5338                               arg1_tree);
5339         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5340
5341         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5342                                   ffecom_gfrt_kindtype (gfrt),
5343                                   FALSE,
5344                                   ((codegen_imp == FFEINTRIN_impIRAND) ?
5345                                    ffecom_f2c_integer_type_node :
5346                                    ffecom_f2c_real_type_node),
5347                                   arg1_tree,
5348                                   dest_tree, dest, dest_used,
5349                                   NULL_TREE, TRUE,
5350                                   ffebld_nonter_hook (expr));
5351       }
5352       return expr_tree;
5353
5354     case FFEINTRIN_impFTELL_subr:
5355     case FFEINTRIN_impUMASK_subr:
5356       {
5357         tree arg1_tree;
5358         tree arg2_tree;
5359
5360         arg1_tree = convert (ffecom_f2c_integer_type_node,
5361                              ffecom_expr (arg1));
5362         arg1_tree = ffecom_1 (ADDR_EXPR,
5363                               build_pointer_type (TREE_TYPE (arg1_tree)),
5364                               arg1_tree);
5365
5366         if (arg2 == NULL)
5367           arg2_tree = NULL_TREE;
5368         else
5369           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
5370
5371         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5372                                   ffecom_gfrt_kindtype (gfrt),
5373                                   FALSE,
5374                                   NULL_TREE,
5375                                   build_tree_list (NULL_TREE, arg1_tree),
5376                                   NULL_TREE, NULL, NULL, NULL_TREE,
5377                                   TRUE,
5378                                   ffebld_nonter_hook (expr));
5379         if (arg2_tree != NULL_TREE) {
5380           expr_tree = ffecom_modify (NULL_TREE, arg2_tree,
5381                                      convert (TREE_TYPE (arg2_tree),
5382                                               expr_tree));
5383         }
5384       }
5385       return expr_tree;
5386
5387     case FFEINTRIN_impCPU_TIME:
5388     case FFEINTRIN_impSECOND_subr:
5389       {
5390         tree arg1_tree;
5391
5392         arg1_tree = ffecom_expr_w (NULL_TREE, arg1);
5393
5394         expr_tree
5395           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5396                           ffecom_gfrt_kindtype (gfrt),
5397                           FALSE,
5398                           NULL_TREE,
5399                           NULL_TREE,
5400                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5401                           ffebld_nonter_hook (expr));
5402
5403         expr_tree
5404           = ffecom_modify (NULL_TREE, arg1_tree,
5405                            convert (TREE_TYPE (arg1_tree),
5406                                     expr_tree));
5407       }
5408       return expr_tree;
5409
5410     case FFEINTRIN_impDTIME_subr:
5411     case FFEINTRIN_impETIME_subr:
5412       {
5413         tree arg1_tree;
5414         tree result_tree;
5415
5416         result_tree = ffecom_expr_w (NULL_TREE, arg2);
5417
5418         arg1_tree = ffecom_ptr_to_expr (arg1);
5419
5420         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5421                                   ffecom_gfrt_kindtype (gfrt),
5422                                   FALSE,
5423                                   NULL_TREE,
5424                                   build_tree_list (NULL_TREE, arg1_tree),
5425                                   NULL_TREE, NULL, NULL, NULL_TREE,
5426                                   TRUE,
5427                                   ffebld_nonter_hook (expr));
5428         expr_tree = ffecom_modify (NULL_TREE, result_tree,
5429                                    convert (TREE_TYPE (result_tree),
5430                                             expr_tree));
5431       }
5432       return expr_tree;
5433
5434       /* Straightforward calls of libf2c routines: */
5435     case FFEINTRIN_impABORT:
5436     case FFEINTRIN_impACCESS:
5437     case FFEINTRIN_impBESJ0:
5438     case FFEINTRIN_impBESJ1:
5439     case FFEINTRIN_impBESJN:
5440     case FFEINTRIN_impBESY0:
5441     case FFEINTRIN_impBESY1:
5442     case FFEINTRIN_impBESYN:
5443     case FFEINTRIN_impCHDIR_func:
5444     case FFEINTRIN_impCHMOD_func:
5445     case FFEINTRIN_impDATE:
5446     case FFEINTRIN_impDATE_AND_TIME:
5447     case FFEINTRIN_impDBESJ0:
5448     case FFEINTRIN_impDBESJ1:
5449     case FFEINTRIN_impDBESJN:
5450     case FFEINTRIN_impDBESY0:
5451     case FFEINTRIN_impDBESY1:
5452     case FFEINTRIN_impDBESYN:
5453     case FFEINTRIN_impDTIME_func:
5454     case FFEINTRIN_impETIME_func:
5455     case FFEINTRIN_impFGETC_func:
5456     case FFEINTRIN_impFGET_func:
5457     case FFEINTRIN_impFNUM:
5458     case FFEINTRIN_impFPUTC_func:
5459     case FFEINTRIN_impFPUT_func:
5460     case FFEINTRIN_impFSEEK:
5461     case FFEINTRIN_impFSTAT_func:
5462     case FFEINTRIN_impFTELL_func:
5463     case FFEINTRIN_impGERROR:
5464     case FFEINTRIN_impGETARG:
5465     case FFEINTRIN_impGETCWD_func:
5466     case FFEINTRIN_impGETENV:
5467     case FFEINTRIN_impGETGID:
5468     case FFEINTRIN_impGETLOG:
5469     case FFEINTRIN_impGETPID:
5470     case FFEINTRIN_impGETUID:
5471     case FFEINTRIN_impGMTIME:
5472     case FFEINTRIN_impHOSTNM_func:
5473     case FFEINTRIN_impIDATE_unix:
5474     case FFEINTRIN_impIDATE_vxt:
5475     case FFEINTRIN_impIERRNO:
5476     case FFEINTRIN_impISATTY:
5477     case FFEINTRIN_impITIME:
5478     case FFEINTRIN_impKILL_func:
5479     case FFEINTRIN_impLINK_func:
5480     case FFEINTRIN_impLNBLNK:
5481     case FFEINTRIN_impLSTAT_func:
5482     case FFEINTRIN_impLTIME:
5483     case FFEINTRIN_impMCLOCK8:
5484     case FFEINTRIN_impMCLOCK:
5485     case FFEINTRIN_impPERROR:
5486     case FFEINTRIN_impRENAME_func:
5487     case FFEINTRIN_impSECNDS:
5488     case FFEINTRIN_impSECOND_func:
5489     case FFEINTRIN_impSLEEP:
5490     case FFEINTRIN_impSRAND:
5491     case FFEINTRIN_impSTAT_func:
5492     case FFEINTRIN_impSYMLNK_func:
5493     case FFEINTRIN_impSYSTEM_CLOCK:
5494     case FFEINTRIN_impSYSTEM_func:
5495     case FFEINTRIN_impTIME8:
5496     case FFEINTRIN_impTIME_unix:
5497     case FFEINTRIN_impTIME_vxt:
5498     case FFEINTRIN_impUMASK_func:
5499     case FFEINTRIN_impUNLINK_func:
5500       break;
5501
5502     case FFEINTRIN_impCTIME_func:       /* CHARACTER functions not handled here. */
5503     case FFEINTRIN_impFDATE_func:       /* CHARACTER functions not handled here. */
5504     case FFEINTRIN_impTTYNAM_func:      /* CHARACTER functions not handled here. */
5505     case FFEINTRIN_impNONE:
5506     case FFEINTRIN_imp:         /* Hush up gcc warning. */
5507       fprintf (stderr, "No %s implementation.\n",
5508                ffeintrin_name_implementation (ffebld_symter_implementation (ffebld_left (expr))));
5509       assert ("unimplemented intrinsic" == NULL);
5510       return error_mark_node;
5511     }
5512
5513   assert (gfrt != FFECOM_gfrt); /* Must have an implementation! */
5514
5515   expr_tree = ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt),
5516                                     ffebld_right (expr));
5517
5518   return ffecom_call_ (ffecom_gfrt_tree_ (gfrt), ffecom_gfrt_kindtype (gfrt),
5519                        (ffe_is_f2c_library () && ffecom_gfrt_complex_[gfrt]),
5520                        tree_type,
5521                        expr_tree, dest_tree, dest, dest_used,
5522                        NULL_TREE, TRUE,
5523                        ffebld_nonter_hook (expr));
5524
5525   /* See bottom of this file for f2c transforms used to determine
5526      many of the above implementations.  The info seems to confuse
5527      Emacs's C mode indentation, which is why it's been moved to
5528      the bottom of this source file.  */
5529 }
5530
5531 #endif
5532 /* For power (exponentiation) where right-hand operand is type INTEGER,
5533    generate in-line code to do it the fast way (which, if the operand
5534    is a constant, might just mean a series of multiplies).  */
5535
5536 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5537 static tree
5538 ffecom_expr_power_integer_ (ffebld expr)
5539 {
5540   tree l = ffecom_expr (ffebld_left (expr));
5541   tree r = ffecom_expr (ffebld_right (expr));
5542   tree ltype = TREE_TYPE (l);
5543   tree rtype = TREE_TYPE (r);
5544   tree result = NULL_TREE;
5545
5546   if (l == error_mark_node
5547       || r == error_mark_node)
5548     return error_mark_node;
5549
5550   if (TREE_CODE (r) == INTEGER_CST)
5551     {
5552       int sgn = tree_int_cst_sgn (r);
5553
5554       if (sgn == 0)
5555         return convert (ltype, integer_one_node);
5556
5557       if ((TREE_CODE (ltype) == INTEGER_TYPE)
5558           && (sgn < 0))
5559         {
5560           /* Reciprocal of integer is either 0, -1, or 1, so after
5561              calculating that (which we leave to the back end to do
5562              or not do optimally), don't bother with any multiplying.  */
5563
5564           result = ffecom_tree_divide_ (ltype,
5565                                         convert (ltype, integer_one_node),
5566                                         l,
5567                                         NULL_TREE, NULL, NULL, NULL_TREE);
5568           r = ffecom_1 (NEGATE_EXPR,
5569                         rtype,
5570                         r);
5571           if ((TREE_INT_CST_LOW (r) & 1) == 0)
5572             result = ffecom_1 (ABS_EXPR, rtype,
5573                                result);
5574         }
5575
5576       /* Generate appropriate series of multiplies, preceded
5577          by divide if the exponent is negative.  */
5578
5579       l = save_expr (l);
5580
5581       if (sgn < 0)
5582         {
5583           l = ffecom_tree_divide_ (ltype,
5584                                    convert (ltype, integer_one_node),
5585                                    l,
5586                                    NULL_TREE, NULL, NULL,
5587                                    ffebld_nonter_hook (expr));
5588           r = ffecom_1 (NEGATE_EXPR, rtype, r);
5589           assert (TREE_CODE (r) == INTEGER_CST);
5590
5591           if (tree_int_cst_sgn (r) < 0)
5592             {                   /* The "most negative" number.  */
5593               r = ffecom_1 (NEGATE_EXPR, rtype,
5594                             ffecom_2 (RSHIFT_EXPR, rtype,
5595                                       r,
5596                                       integer_one_node));
5597               l = save_expr (l);
5598               l = ffecom_2 (MULT_EXPR, ltype,
5599                             l,
5600                             l);
5601             }
5602         }
5603
5604       for (;;)
5605         {
5606           if (TREE_INT_CST_LOW (r) & 1)
5607             {
5608               if (result == NULL_TREE)
5609                 result = l;
5610               else
5611                 result = ffecom_2 (MULT_EXPR, ltype,
5612                                    result,
5613                                    l);
5614             }
5615
5616           r = ffecom_2 (RSHIFT_EXPR, rtype,
5617                         r,
5618                         integer_one_node);
5619           if (integer_zerop (r))
5620             break;
5621           assert (TREE_CODE (r) == INTEGER_CST);
5622
5623           l = save_expr (l);
5624           l = ffecom_2 (MULT_EXPR, ltype,
5625                         l,
5626                         l);
5627         }
5628       return result;
5629     }
5630
5631   /* Though rhs isn't a constant, in-line code cannot be expanded
5632      while transforming dummies
5633      because the back end cannot be easily convinced to generate
5634      stores (MODIFY_EXPR), handle temporaries, and so on before
5635      all the appropriate rtx's have been generated for things like
5636      dummy args referenced in rhs -- which doesn't happen until
5637      store_parm_decls() is called (expand_function_start, I believe,
5638      does the actual rtx-stuffing of PARM_DECLs).
5639
5640      So, in this case, let the caller generate the call to the
5641      run-time-library function to evaluate the power for us.  */
5642
5643   if (ffecom_transform_only_dummies_)
5644     return NULL_TREE;
5645
5646   /* Right-hand operand not a constant, expand in-line code to figure
5647      out how to do the multiplies, &c.
5648
5649      The returned expression is expressed this way in GNU C, where l and
5650      r are the "inputs":
5651
5652      ({ typeof (r) rtmp = r;
5653         typeof (l) ltmp = l;
5654         typeof (l) result;
5655
5656         if (rtmp == 0)
5657           result = 1;
5658         else
5659           {
5660             if ((basetypeof (l) == basetypeof (int))
5661                 && (rtmp < 0))
5662               {
5663                 result = ((typeof (l)) 1) / ltmp;
5664                 if ((ltmp < 0) && (((-rtmp) & 1) == 0))
5665                   result = -result;
5666               }
5667             else
5668               {
5669                 result = 1;
5670                 if ((basetypeof (l) != basetypeof (int))
5671                     && (rtmp < 0))
5672                   {
5673                     ltmp = ((typeof (l)) 1) / ltmp;
5674                     rtmp = -rtmp;
5675                     if (rtmp < 0)
5676                       {
5677                         rtmp = -(rtmp >> 1);
5678                         ltmp *= ltmp;
5679                       }
5680                   }
5681                 for (;;)
5682                   {
5683                     if (rtmp & 1)
5684                       result *= ltmp;
5685                     if ((rtmp >>= 1) == 0)
5686                       break;
5687                     ltmp *= ltmp;
5688                   }
5689               }
5690           }
5691         result;
5692      })
5693
5694      Note that some of the above is compile-time collapsable, such as
5695      the first part of the if statements that checks the base type of
5696      l against int.  The if statements are phrased that way to suggest
5697      an easy way to generate the if/else constructs here, knowing that
5698      the back end should (and probably does) eliminate the resulting
5699      dead code (either the int case or the non-int case), something
5700      it couldn't do without the redundant phrasing, requiring explicit
5701      dead-code elimination here, which would be kind of difficult to
5702      read.  */
5703
5704   {
5705     tree rtmp;
5706     tree ltmp;
5707     tree divide;
5708     tree basetypeof_l_is_int;
5709     tree se;
5710     tree t;
5711
5712     basetypeof_l_is_int
5713       = build_int_2 ((TREE_CODE (ltype) == INTEGER_TYPE), 0);
5714
5715     se = expand_start_stmt_expr ();
5716
5717     ffecom_start_compstmt ();
5718
5719 #ifndef HAHA
5720     rtmp = ffecom_make_tempvar ("power_r", rtype,
5721                                 FFETARGET_charactersizeNONE, -1);
5722     ltmp = ffecom_make_tempvar ("power_l", ltype,
5723                                 FFETARGET_charactersizeNONE, -1);
5724     result = ffecom_make_tempvar ("power_res", ltype,
5725                                   FFETARGET_charactersizeNONE, -1);
5726     if (TREE_CODE (ltype) == COMPLEX_TYPE
5727         || TREE_CODE (ltype) == RECORD_TYPE)
5728       divide = ffecom_make_tempvar ("power_div", ltype,
5729                                     FFETARGET_charactersizeNONE, -1);
5730     else
5731       divide = NULL_TREE;
5732 #else  /* HAHA */
5733     {
5734       tree hook;
5735
5736       hook = ffebld_nonter_hook (expr);
5737       assert (hook);
5738       assert (TREE_CODE (hook) == TREE_VEC);
5739       assert (TREE_VEC_LENGTH (hook) == 4);
5740       rtmp = TREE_VEC_ELT (hook, 0);
5741       ltmp = TREE_VEC_ELT (hook, 1);
5742       result = TREE_VEC_ELT (hook, 2);
5743       divide = TREE_VEC_ELT (hook, 3);
5744       if (TREE_CODE (ltype) == COMPLEX_TYPE
5745           || TREE_CODE (ltype) == RECORD_TYPE)
5746         assert (divide);
5747       else
5748         assert (! divide);
5749     }
5750 #endif  /* HAHA */
5751
5752     expand_expr_stmt (ffecom_modify (void_type_node,
5753                                      rtmp,
5754                                      r));
5755     expand_expr_stmt (ffecom_modify (void_type_node,
5756                                      ltmp,
5757                                      l));
5758     expand_start_cond (ffecom_truth_value
5759                        (ffecom_2 (EQ_EXPR, integer_type_node,
5760                                   rtmp,
5761                                   convert (rtype, integer_zero_node))),
5762                        0);
5763     expand_expr_stmt (ffecom_modify (void_type_node,
5764                                      result,
5765                                      convert (ltype, integer_one_node)));
5766     expand_start_else ();
5767     if (! integer_zerop (basetypeof_l_is_int))
5768       {
5769         expand_start_cond (ffecom_2 (LT_EXPR, integer_type_node,
5770                                      rtmp,
5771                                      convert (rtype,
5772                                               integer_zero_node)),
5773                            0);
5774         expand_expr_stmt (ffecom_modify (void_type_node,
5775                                          result,
5776                                          ffecom_tree_divide_
5777                                          (ltype,
5778                                           convert (ltype, integer_one_node),
5779                                           ltmp,
5780                                           NULL_TREE, NULL, NULL,
5781                                           divide)));
5782         expand_start_cond (ffecom_truth_value
5783                            (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5784                                       ffecom_2 (LT_EXPR, integer_type_node,
5785                                                 ltmp,
5786                                                 convert (ltype,
5787                                                          integer_zero_node)),
5788                                       ffecom_2 (EQ_EXPR, integer_type_node,
5789                                                 ffecom_2 (BIT_AND_EXPR,
5790                                                           rtype,
5791                                                           ffecom_1 (NEGATE_EXPR,
5792                                                                     rtype,
5793                                                                     rtmp),
5794                                                           convert (rtype,
5795                                                                    integer_one_node)),
5796                                                 convert (rtype,
5797                                                          integer_zero_node)))),
5798                            0);
5799         expand_expr_stmt (ffecom_modify (void_type_node,
5800                                          result,
5801                                          ffecom_1 (NEGATE_EXPR,
5802                                                    ltype,
5803                                                    result)));
5804         expand_end_cond ();
5805         expand_start_else ();
5806       }
5807     expand_expr_stmt (ffecom_modify (void_type_node,
5808                                      result,
5809                                      convert (ltype, integer_one_node)));
5810     expand_start_cond (ffecom_truth_value
5811                        (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5812                                   ffecom_truth_value_invert
5813                                   (basetypeof_l_is_int),
5814                                   ffecom_2 (LT_EXPR, integer_type_node,
5815                                             rtmp,
5816                                             convert (rtype,
5817                                                      integer_zero_node)))),
5818                        0);
5819     expand_expr_stmt (ffecom_modify (void_type_node,
5820                                      ltmp,
5821                                      ffecom_tree_divide_
5822                                      (ltype,
5823                                       convert (ltype, integer_one_node),
5824                                       ltmp,
5825                                       NULL_TREE, NULL, NULL,
5826                                       divide)));
5827     expand_expr_stmt (ffecom_modify (void_type_node,
5828                                      rtmp,
5829                                      ffecom_1 (NEGATE_EXPR, rtype,
5830                                                rtmp)));
5831     expand_start_cond (ffecom_truth_value
5832                        (ffecom_2 (LT_EXPR, integer_type_node,
5833                                   rtmp,
5834                                   convert (rtype, integer_zero_node))),
5835                        0);
5836     expand_expr_stmt (ffecom_modify (void_type_node,
5837                                      rtmp,
5838                                      ffecom_1 (NEGATE_EXPR, rtype,
5839                                                ffecom_2 (RSHIFT_EXPR,
5840                                                          rtype,
5841                                                          rtmp,
5842                                                          integer_one_node))));
5843     expand_expr_stmt (ffecom_modify (void_type_node,
5844                                      ltmp,
5845                                      ffecom_2 (MULT_EXPR, ltype,
5846                                                ltmp,
5847                                                ltmp)));
5848     expand_end_cond ();
5849     expand_end_cond ();
5850     expand_start_loop (1);
5851     expand_start_cond (ffecom_truth_value
5852                        (ffecom_2 (BIT_AND_EXPR, rtype,
5853                                   rtmp,
5854                                   convert (rtype, integer_one_node))),
5855                        0);
5856     expand_expr_stmt (ffecom_modify (void_type_node,
5857                                      result,
5858                                      ffecom_2 (MULT_EXPR, ltype,
5859                                                result,
5860                                                ltmp)));
5861     expand_end_cond ();
5862     expand_exit_loop_if_false (NULL,
5863                                ffecom_truth_value
5864                                (ffecom_modify (rtype,
5865                                                rtmp,
5866                                                ffecom_2 (RSHIFT_EXPR,
5867                                                          rtype,
5868                                                          rtmp,
5869                                                          integer_one_node))));
5870     expand_expr_stmt (ffecom_modify (void_type_node,
5871                                      ltmp,
5872                                      ffecom_2 (MULT_EXPR, ltype,
5873                                                ltmp,
5874                                                ltmp)));
5875     expand_end_loop ();
5876     expand_end_cond ();
5877     if (!integer_zerop (basetypeof_l_is_int))
5878       expand_end_cond ();
5879     expand_expr_stmt (result);
5880
5881     t = ffecom_end_compstmt ();
5882
5883     result = expand_end_stmt_expr (se);
5884
5885     /* This code comes from c-parse.in, after its expand_end_stmt_expr.  */
5886
5887     if (TREE_CODE (t) == BLOCK)
5888       {
5889         /* Make a BIND_EXPR for the BLOCK already made.  */
5890         result = build (BIND_EXPR, TREE_TYPE (result),
5891                         NULL_TREE, result, t);
5892         /* Remove the block from the tree at this point.
5893            It gets put back at the proper place
5894            when the BIND_EXPR is expanded.  */
5895         delete_block (t);
5896       }
5897     else
5898       result = t;
5899   }
5900
5901   return result;
5902 }
5903
5904 #endif
5905 /* ffecom_expr_transform_ -- Transform symbols in expr
5906
5907    ffebld expr;  // FFE expression.
5908    ffecom_expr_transform_ (expr);
5909
5910    Recursive descent on expr while transforming any untransformed SYMTERs.  */
5911
5912 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5913 static void
5914 ffecom_expr_transform_ (ffebld expr)
5915 {
5916   tree t;
5917   ffesymbol s;
5918
5919 tail_recurse:                   /* :::::::::::::::::::: */
5920
5921   if (expr == NULL)
5922     return;
5923
5924   switch (ffebld_op (expr))
5925     {
5926     case FFEBLD_opSYMTER:
5927       s = ffebld_symter (expr);
5928       t = ffesymbol_hook (s).decl_tree;
5929       if ((t == NULL_TREE)
5930           && ((ffesymbol_kind (s) != FFEINFO_kindNONE)
5931               || ((ffesymbol_where (s) != FFEINFO_whereNONE)
5932                   && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC))))
5933         {
5934           s = ffecom_sym_transform_ (s);
5935           t = ffesymbol_hook (s).decl_tree;     /* Sfunc expr non-dummy,
5936                                                    DIMENSION expr? */
5937         }
5938       break;                    /* Ok if (t == NULL) here. */
5939
5940     case FFEBLD_opITEM:
5941       ffecom_expr_transform_ (ffebld_head (expr));
5942       expr = ffebld_trail (expr);
5943       goto tail_recurse;        /* :::::::::::::::::::: */
5944
5945     default:
5946       break;
5947     }
5948
5949   switch (ffebld_arity (expr))
5950     {
5951     case 2:
5952       ffecom_expr_transform_ (ffebld_left (expr));
5953       expr = ffebld_right (expr);
5954       goto tail_recurse;        /* :::::::::::::::::::: */
5955
5956     case 1:
5957       expr = ffebld_left (expr);
5958       goto tail_recurse;        /* :::::::::::::::::::: */
5959
5960     default:
5961       break;
5962     }
5963
5964   return;
5965 }
5966
5967 #endif
5968 /* Make a type based on info in live f2c.h file.  */
5969
5970 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5971 static void
5972 ffecom_f2c_make_type_ (tree *type, int tcode, const char *name)
5973 {
5974   switch (tcode)
5975     {
5976     case FFECOM_f2ccodeCHAR:
5977       *type = make_signed_type (CHAR_TYPE_SIZE);
5978       break;
5979
5980     case FFECOM_f2ccodeSHORT:
5981       *type = make_signed_type (SHORT_TYPE_SIZE);
5982       break;
5983
5984     case FFECOM_f2ccodeINT:
5985       *type = make_signed_type (INT_TYPE_SIZE);
5986       break;
5987
5988     case FFECOM_f2ccodeLONG:
5989       *type = make_signed_type (LONG_TYPE_SIZE);
5990       break;
5991
5992     case FFECOM_f2ccodeLONGLONG:
5993       *type = make_signed_type (LONG_LONG_TYPE_SIZE);
5994       break;
5995
5996     case FFECOM_f2ccodeCHARPTR:
5997       *type = build_pointer_type (DEFAULT_SIGNED_CHAR
5998                                   ? signed_char_type_node
5999                                   : unsigned_char_type_node);
6000       break;
6001
6002     case FFECOM_f2ccodeFLOAT:
6003       *type = make_node (REAL_TYPE);
6004       TYPE_PRECISION (*type) = FLOAT_TYPE_SIZE;
6005       layout_type (*type);
6006       break;
6007
6008     case FFECOM_f2ccodeDOUBLE:
6009       *type = make_node (REAL_TYPE);
6010       TYPE_PRECISION (*type) = DOUBLE_TYPE_SIZE;
6011       layout_type (*type);
6012       break;
6013
6014     case FFECOM_f2ccodeLONGDOUBLE:
6015       *type = make_node (REAL_TYPE);
6016       TYPE_PRECISION (*type) = LONG_DOUBLE_TYPE_SIZE;
6017       layout_type (*type);
6018       break;
6019
6020     case FFECOM_f2ccodeTWOREALS:
6021       *type = ffecom_make_complex_type_ (ffecom_f2c_real_type_node);
6022       break;
6023
6024     case FFECOM_f2ccodeTWODOUBLEREALS:
6025       *type = ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node);
6026       break;
6027
6028     default:
6029       assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL);
6030       *type = error_mark_node;
6031       return;
6032     }
6033
6034   pushdecl (build_decl (TYPE_DECL,
6035                         ffecom_get_invented_identifier ("__g77_f2c_%s", name),
6036                         *type));
6037 }
6038
6039 #endif
6040 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6041 /* Set the f2c list-directed-I/O code for whatever (integral) type has the
6042    given size.  */
6043
6044 static void
6045 ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
6046                           int code)
6047 {
6048   int j;
6049   tree t;
6050
6051   for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
6052     if (((t = ffecom_tree_type[bt][j]) != NULL_TREE)
6053         && (TREE_INT_CST_LOW (TYPE_SIZE (t)) == size))
6054       {
6055         assert (code != -1);
6056         ffecom_f2c_typecode_[bt][j] = code;
6057         code = -1;
6058       }
6059 }
6060
6061 #endif
6062 /* Finish up globals after doing all program units in file
6063
6064    Need to handle only uninitialized COMMON areas.  */
6065
6066 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6067 static ffeglobal
6068 ffecom_finish_global_ (ffeglobal global)
6069 {
6070   tree cbtype;
6071   tree cbt;
6072   tree size;
6073
6074   if (ffeglobal_type (global) != FFEGLOBAL_typeCOMMON)
6075       return global;
6076
6077   if (ffeglobal_common_init (global))
6078       return global;
6079
6080   cbt = ffeglobal_hook (global);
6081   if ((cbt == NULL_TREE)
6082       || !ffeglobal_common_have_size (global))
6083     return global;              /* No need to make common, never ref'd. */
6084
6085   suspend_momentary ();
6086
6087   DECL_EXTERNAL (cbt) = 0;
6088
6089   /* Give the array a size now.  */
6090
6091   size = build_int_2 ((ffeglobal_common_size (global)
6092                       + ffeglobal_common_pad (global)) - 1,
6093                       0);
6094
6095   cbtype = TREE_TYPE (cbt);
6096   TYPE_DOMAIN (cbtype) = build_range_type (integer_type_node,
6097                                            integer_zero_node,
6098                                            size);
6099   if (!TREE_TYPE (size))
6100     TREE_TYPE (size) = TYPE_DOMAIN (cbtype);
6101   layout_type (cbtype);
6102
6103   cbt = start_decl (cbt, FALSE);
6104   assert (cbt == ffeglobal_hook (global));
6105
6106   finish_decl (cbt, NULL_TREE, FALSE);
6107
6108   return global;
6109 }
6110
6111 #endif
6112 /* Finish up any untransformed symbols.  */
6113
6114 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6115 static ffesymbol
6116 ffecom_finish_symbol_transform_ (ffesymbol s)
6117 {
6118   if ((s == NULL) || (TREE_CODE (current_function_decl) == ERROR_MARK))
6119     return s;
6120
6121   /* It's easy to know to transform an untransformed symbol, to make sure
6122      we put out debugging info for it.  But COMMON variables, unlike
6123      EQUIVALENCE ones, aren't given declarations in addition to the
6124      tree expressions that specify offsets, because COMMON variables
6125      can be referenced in the outer scope where only dummy arguments
6126      (PARM_DECLs) should really be seen.  To be safe, just don't do any
6127      VAR_DECLs for COMMON variables when we transform them for real
6128      use, and therefore we do all the VAR_DECL creating here.  */
6129
6130   if (ffesymbol_hook (s).decl_tree == NULL_TREE)
6131     {
6132       if (ffesymbol_kind (s) != FFEINFO_kindNONE
6133           || (ffesymbol_where (s) != FFEINFO_whereNONE
6134               && ffesymbol_where (s) != FFEINFO_whereINTRINSIC
6135               && ffesymbol_where (s) != FFEINFO_whereDUMMY))
6136         /* Not transformed, and not CHARACTER*(*), and not a dummy
6137            argument, which can happen only if the entry point names
6138            it "rides in on" are all invalidated for other reasons.  */
6139         s = ffecom_sym_transform_ (s);
6140     }
6141
6142   if ((ffesymbol_where (s) == FFEINFO_whereCOMMON)
6143       && (ffesymbol_hook (s).decl_tree != error_mark_node))
6144     {
6145       int yes = suspend_momentary ();
6146
6147       /* This isn't working, at least for dbxout.  The .s file looks
6148          okay to me (burley), but in gdb 4.9 at least, the variables
6149          appear to reside somewhere outside of the common area, so
6150          it doesn't make sense to mislead anyone by generating the info
6151          on those variables until this is fixed.  NOTE: Same problem
6152          with EQUIVALENCE, sadly...see similar #if later.  */
6153       ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s)),
6154                              ffesymbol_storage (s));
6155
6156       resume_momentary (yes);
6157     }
6158
6159   return s;
6160 }
6161
6162 #endif
6163 /* Append underscore(s) to name before calling get_identifier.  "us"
6164    is nonzero if the name already contains an underscore and thus
6165    needs two underscores appended.  */
6166
6167 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6168 static tree
6169 ffecom_get_appended_identifier_ (char us, const char *name)
6170 {
6171   int i;
6172   char *newname;
6173   tree id;
6174
6175   newname = xmalloc ((i = strlen (name)) + 1
6176                      + ffe_is_underscoring ()
6177                      + us);
6178   memcpy (newname, name, i);
6179   newname[i] = '_';
6180   newname[i + us] = '_';
6181   newname[i + 1 + us] = '\0';
6182   id = get_identifier (newname);
6183
6184   free (newname);
6185
6186   return id;
6187 }
6188
6189 #endif
6190 /* Decide whether to append underscore to name before calling
6191    get_identifier.  */
6192
6193 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6194 static tree
6195 ffecom_get_external_identifier_ (ffesymbol s)
6196 {
6197   char us;
6198   const char *name = ffesymbol_text (s);
6199
6200   /* If name is a built-in name, just return it as is.  */
6201
6202   if (!ffe_is_underscoring ()
6203       || (strcmp (name, FFETARGET_nameBLANK_COMMON) == 0)
6204 #if FFETARGET_isENFORCED_MAIN_NAME
6205       || (strcmp (name, FFETARGET_nameENFORCED_NAME) == 0)
6206 #else
6207       || (strcmp (name, FFETARGET_nameUNNAMED_MAIN) == 0)
6208 #endif
6209       || (strcmp (name, FFETARGET_nameUNNAMED_BLOCK_DATA) == 0))
6210     return get_identifier (name);
6211
6212   us = ffe_is_second_underscore ()
6213     ? (strchr (name, '_') != NULL)
6214       : 0;
6215
6216   return ffecom_get_appended_identifier_ (us, name);
6217 }
6218
6219 #endif
6220 /* Decide whether to append underscore to internal name before calling
6221    get_identifier.
6222
6223    This is for non-external, top-function-context names only.  Transform
6224    identifier so it doesn't conflict with the transformed result
6225    of using a _different_ external name.  E.g. if "CALL FOO" is
6226    transformed into "FOO_();", then the variable in "FOO_ = 3"
6227    must be transformed into something that does not conflict, since
6228    these two things should be independent.
6229
6230    The transformation is as follows.  If the name does not contain
6231    an underscore, there is no possible conflict, so just return.
6232    If the name does contain an underscore, then transform it just
6233    like we transform an external identifier.  */
6234
6235 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6236 static tree
6237 ffecom_get_identifier_ (const char *name)
6238 {
6239   /* If name does not contain an underscore, just return it as is.  */
6240
6241   if (!ffe_is_underscoring ()
6242       || (strchr (name, '_') == NULL))
6243     return get_identifier (name);
6244
6245   return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
6246                                           name);
6247 }
6248
6249 #endif
6250 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
6251
6252    tree t;
6253    ffesymbol s;  // kindFUNCTION, whereIMMEDIATE.
6254    t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
6255          ffesymbol_kindtype(s));
6256
6257    Call after setting up containing function and getting trees for all
6258    other symbols.  */
6259
6260 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6261 static tree
6262 ffecom_gen_sfuncdef_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt)
6263 {
6264   ffebld expr = ffesymbol_sfexpr (s);
6265   tree type;
6266   tree func;
6267   tree result;
6268   bool charfunc = (bt == FFEINFO_basictypeCHARACTER);
6269   static bool recurse = FALSE;
6270   int yes;
6271   int old_lineno = lineno;
6272   char *old_input_filename = input_filename;
6273
6274   ffecom_nested_entry_ = s;
6275
6276   /* For now, we don't have a handy pointer to where the sfunc is actually
6277      defined, though that should be easy to add to an ffesymbol. (The
6278      token/where info available might well point to the place where the type
6279      of the sfunc is declared, especially if that precedes the place where
6280      the sfunc itself is defined, which is typically the case.)  We should
6281      put out a null pointer rather than point somewhere wrong, but I want to
6282      see how it works at this point.  */
6283
6284   input_filename = ffesymbol_where_filename (s);
6285   lineno = ffesymbol_where_filelinenum (s);
6286
6287   /* Pretransform the expression so any newly discovered things belong to the
6288      outer program unit, not to the statement function. */
6289
6290   ffecom_expr_transform_ (expr);
6291
6292   /* Make sure no recursive invocation of this fn (a specific case of failing
6293      to pretransform an sfunc's expression, i.e. where its expression
6294      references another untransformed sfunc) happens. */
6295
6296   assert (!recurse);
6297   recurse = TRUE;
6298
6299   yes = suspend_momentary ();
6300
6301   push_f_function_context ();
6302
6303   if (charfunc)
6304     type = void_type_node;
6305   else
6306     {
6307       type = ffecom_tree_type[bt][kt];
6308       if (type == NULL_TREE)
6309         type = integer_type_node;       /* _sym_exec_transition reports
6310                                            error. */
6311     }
6312
6313   start_function (ffecom_get_identifier_ (ffesymbol_text (s)),
6314                   build_function_type (type, NULL_TREE),
6315                   1,            /* nested/inline */
6316                   0);           /* TREE_PUBLIC */
6317
6318   /* We don't worry about COMPLEX return values here, because this is
6319      entirely internal to our code, and gcc has the ability to return COMPLEX
6320      directly as a value.  */
6321
6322   yes = suspend_momentary ();
6323
6324   if (charfunc)
6325     {                           /* Prepend arg for where result goes. */
6326       tree type;
6327
6328       type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
6329
6330       result = ffecom_get_invented_identifier ("__g77_%s", "result");
6331
6332       ffecom_char_enhance_arg_ (&type, s);      /* Ignore returned length. */
6333
6334       type = build_pointer_type (type);
6335       result = build_decl (PARM_DECL, result, type);
6336
6337       push_parm_decl (result);
6338     }
6339   else
6340     result = NULL_TREE;         /* Not ref'd if !charfunc. */
6341
6342   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s), TRUE);
6343
6344   resume_momentary (yes);
6345
6346   store_parm_decls (0);
6347
6348   ffecom_start_compstmt ();
6349
6350   if (expr != NULL)
6351     {
6352       if (charfunc)
6353         {
6354           ffetargetCharacterSize sz = ffesymbol_size (s);
6355           tree result_length;
6356
6357           result_length = build_int_2 (sz, 0);
6358           TREE_TYPE (result_length) = ffecom_f2c_ftnlen_type_node;
6359
6360           ffecom_prepare_let_char_ (sz, expr);
6361
6362           ffecom_prepare_end ();
6363
6364           ffecom_let_char_ (result, result_length, sz, expr);
6365           expand_null_return ();
6366         }
6367       else
6368         {
6369           ffecom_prepare_expr (expr);
6370
6371           ffecom_prepare_end ();
6372
6373           expand_return (ffecom_modify (NULL_TREE,
6374                                         DECL_RESULT (current_function_decl),
6375                                         ffecom_expr (expr)));
6376         }
6377
6378       clear_momentary ();
6379     }
6380
6381   ffecom_end_compstmt ();
6382
6383   func = current_function_decl;
6384   finish_function (1);
6385
6386   pop_f_function_context ();
6387
6388   resume_momentary (yes);
6389
6390   recurse = FALSE;
6391
6392   lineno = old_lineno;
6393   input_filename = old_input_filename;
6394
6395   ffecom_nested_entry_ = NULL;
6396
6397   return func;
6398 }
6399
6400 #endif
6401
6402 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6403 static const char *
6404 ffecom_gfrt_args_ (ffecomGfrt ix)
6405 {
6406   return ffecom_gfrt_argstring_[ix];
6407 }
6408
6409 #endif
6410 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6411 static tree
6412 ffecom_gfrt_tree_ (ffecomGfrt ix)
6413 {
6414   if (ffecom_gfrt_[ix] == NULL_TREE)
6415     ffecom_make_gfrt_ (ix);
6416
6417   return ffecom_1 (ADDR_EXPR,
6418                    build_pointer_type (TREE_TYPE (ffecom_gfrt_[ix])),
6419                    ffecom_gfrt_[ix]);
6420 }
6421
6422 #endif
6423 /* Return initialize-to-zero expression for this VAR_DECL.  */
6424
6425 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6426 /* A somewhat evil way to prevent the garbage collector
6427    from collecting 'tree' structures.  */
6428 #define NUM_TRACKED_CHUNK 63
6429 static struct tree_ggc_tracker
6430 {
6431   struct tree_ggc_tracker *next;
6432   tree trees[NUM_TRACKED_CHUNK];
6433 } *tracker_head = NULL;
6434
6435 static void
6436 mark_tracker_head (void *arg)
6437 {
6438   struct tree_ggc_tracker *head;
6439   int i;
6440
6441   for (head = * (struct tree_ggc_tracker **) arg;
6442        head != NULL;
6443        head = head->next)
6444   {
6445     ggc_mark (head);
6446     for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6447       ggc_mark_tree (head->trees[i]);
6448   }
6449 }
6450
6451 void
6452 ffecom_save_tree_forever (tree t)
6453 {
6454   int i;
6455   if (tracker_head != NULL)
6456     for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6457       if (tracker_head->trees[i] == NULL)
6458         {
6459           tracker_head->trees[i] = t;
6460           return;
6461         }
6462
6463   {
6464     /* Need to allocate a new block.  */
6465     struct tree_ggc_tracker *old_head = tracker_head;
6466
6467     tracker_head = ggc_alloc (sizeof (*tracker_head));
6468     tracker_head->next = old_head;
6469     tracker_head->trees[0] = t;
6470     for (i = 1; i < NUM_TRACKED_CHUNK; i++)
6471       tracker_head->trees[i] = NULL;
6472   }
6473 }
6474
6475 static tree
6476 ffecom_init_zero_ (tree decl)
6477 {
6478   tree init;
6479   int incremental = TREE_STATIC (decl);
6480   tree type = TREE_TYPE (decl);
6481
6482   if (incremental)
6483     {
6484       make_decl_rtl (decl, NULL, TREE_PUBLIC (decl) ? 1 : 0);
6485       assemble_variable (decl, TREE_PUBLIC (decl) ? 1 : 0, 0, 1);
6486     }
6487
6488   push_momentary ();
6489
6490   if ((TREE_CODE (type) != ARRAY_TYPE)
6491       && (TREE_CODE (type) != RECORD_TYPE)
6492       && (TREE_CODE (type) != UNION_TYPE)
6493       && !incremental)
6494     init = convert (type, integer_zero_node);
6495   else if (!incremental)
6496     {
6497       int momentary = suspend_momentary ();
6498
6499       init = build (CONSTRUCTOR, type, NULL_TREE, NULL_TREE);
6500       TREE_CONSTANT (init) = 1;
6501       TREE_STATIC (init) = 1;
6502
6503       resume_momentary (momentary);
6504     }
6505   else
6506     {
6507       int momentary = suspend_momentary ();
6508
6509       assemble_zeros (int_size_in_bytes (type));
6510       init = error_mark_node;
6511
6512       resume_momentary (momentary);
6513     }
6514
6515   pop_momentary_nofree ();
6516
6517   return init;
6518 }
6519
6520 #endif
6521 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6522 static tree
6523 ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
6524                          tree *maybe_tree)
6525 {
6526   tree expr_tree;
6527   tree length_tree;
6528
6529   switch (ffebld_op (arg))
6530     {
6531     case FFEBLD_opCONTER:       /* For F90, check 0-length. */
6532       if (ffetarget_length_character1
6533           (ffebld_constant_character1
6534            (ffebld_conter (arg))) == 0)
6535         {
6536           *maybe_tree = integer_zero_node;
6537           return convert (tree_type, integer_zero_node);
6538         }
6539
6540       *maybe_tree = integer_one_node;
6541       expr_tree = build_int_2 (*ffetarget_text_character1
6542                                (ffebld_constant_character1
6543                                 (ffebld_conter (arg))),
6544                                0);
6545       TREE_TYPE (expr_tree) = tree_type;
6546       return expr_tree;
6547
6548     case FFEBLD_opSYMTER:
6549     case FFEBLD_opARRAYREF:
6550     case FFEBLD_opFUNCREF:
6551     case FFEBLD_opSUBSTR:
6552       ffecom_char_args_ (&expr_tree, &length_tree, arg);
6553
6554       if ((expr_tree == error_mark_node)
6555           || (length_tree == error_mark_node))
6556         {
6557           *maybe_tree = error_mark_node;
6558           return error_mark_node;
6559         }
6560
6561       if (integer_zerop (length_tree))
6562         {
6563           *maybe_tree = integer_zero_node;
6564           return convert (tree_type, integer_zero_node);
6565         }
6566
6567       expr_tree
6568         = ffecom_1 (INDIRECT_REF,
6569                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6570                     expr_tree);
6571       expr_tree
6572         = ffecom_2 (ARRAY_REF,
6573                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6574                     expr_tree,
6575                     integer_one_node);
6576       expr_tree = convert (tree_type, expr_tree);
6577
6578       if (TREE_CODE (length_tree) == INTEGER_CST)
6579         *maybe_tree = integer_one_node;
6580       else                      /* Must check length at run time.  */
6581         *maybe_tree
6582           = ffecom_truth_value
6583             (ffecom_2 (GT_EXPR, integer_type_node,
6584                        length_tree,
6585                        ffecom_f2c_ftnlen_zero_node));
6586       return expr_tree;
6587
6588     case FFEBLD_opPAREN:
6589     case FFEBLD_opCONVERT:
6590       if (ffeinfo_size (ffebld_info (arg)) == 0)
6591         {
6592           *maybe_tree = integer_zero_node;
6593           return convert (tree_type, integer_zero_node);
6594         }
6595       return ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6596                                       maybe_tree);
6597
6598     case FFEBLD_opCONCATENATE:
6599       {
6600         tree maybe_left;
6601         tree maybe_right;
6602         tree expr_left;
6603         tree expr_right;
6604
6605         expr_left = ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6606                                              &maybe_left);
6607         expr_right = ffecom_intrinsic_ichar_ (tree_type, ffebld_right (arg),
6608                                               &maybe_right);
6609         *maybe_tree = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
6610                                 maybe_left,
6611                                 maybe_right);
6612         expr_tree = ffecom_3 (COND_EXPR, tree_type,
6613                               maybe_left,
6614                               expr_left,
6615                               expr_right);
6616         return expr_tree;
6617       }
6618
6619     default:
6620       assert ("bad op in ICHAR" == NULL);
6621       return error_mark_node;
6622     }
6623 }
6624
6625 #endif
6626 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
6627
6628    tree length_arg;
6629    ffebld expr;
6630    length_arg = ffecom_intrinsic_len_ (expr);
6631
6632    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
6633    subexpressions by constructing the appropriate tree for the
6634    length-of-character-text argument in a calling sequence.  */
6635
6636 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6637 static tree
6638 ffecom_intrinsic_len_ (ffebld expr)
6639 {
6640   ffetargetCharacter1 val;
6641   tree length;
6642
6643   switch (ffebld_op (expr))
6644     {
6645     case FFEBLD_opCONTER:
6646       val = ffebld_constant_character1 (ffebld_conter (expr));
6647       length = build_int_2 (ffetarget_length_character1 (val), 0);
6648       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6649       break;
6650
6651     case FFEBLD_opSYMTER:
6652       {
6653         ffesymbol s = ffebld_symter (expr);
6654         tree item;
6655
6656         item = ffesymbol_hook (s).decl_tree;
6657         if (item == NULL_TREE)
6658           {
6659             s = ffecom_sym_transform_ (s);
6660             item = ffesymbol_hook (s).decl_tree;
6661           }
6662         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
6663           {
6664             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
6665               length = ffesymbol_hook (s).length_tree;
6666             else
6667               {
6668                 length = build_int_2 (ffesymbol_size (s), 0);
6669                 TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6670               }
6671           }
6672         else if (item == error_mark_node)
6673           length = error_mark_node;
6674         else                    /* FFEINFO_kindFUNCTION: */
6675           length = NULL_TREE;
6676       }
6677       break;
6678
6679     case FFEBLD_opARRAYREF:
6680       length = ffecom_intrinsic_len_ (ffebld_left (expr));
6681       break;
6682
6683     case FFEBLD_opSUBSTR:
6684       {
6685         ffebld start;
6686         ffebld end;
6687         ffebld thing = ffebld_right (expr);
6688         tree start_tree;
6689         tree end_tree;
6690
6691         assert (ffebld_op (thing) == FFEBLD_opITEM);
6692         start = ffebld_head (thing);
6693         thing = ffebld_trail (thing);
6694         assert (ffebld_trail (thing) == NULL);
6695         end = ffebld_head (thing);
6696
6697         length = ffecom_intrinsic_len_ (ffebld_left (expr));
6698
6699         if (length == error_mark_node)
6700           break;
6701
6702         if (start == NULL)
6703           {
6704             if (end == NULL)
6705               ;
6706             else
6707               {
6708                 length = convert (ffecom_f2c_ftnlen_type_node,
6709                                   ffecom_expr (end));
6710               }
6711           }
6712         else
6713           {
6714             start_tree = convert (ffecom_f2c_ftnlen_type_node,
6715                                   ffecom_expr (start));
6716
6717             if (start_tree == error_mark_node)
6718               {
6719                 length = error_mark_node;
6720                 break;
6721               }
6722
6723             if (end == NULL)
6724               {
6725                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6726                                    ffecom_f2c_ftnlen_one_node,
6727                                    ffecom_2 (MINUS_EXPR,
6728                                              ffecom_f2c_ftnlen_type_node,
6729                                              length,
6730                                              start_tree));
6731               }
6732             else
6733               {
6734                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
6735                                     ffecom_expr (end));
6736
6737                 if (end_tree == error_mark_node)
6738                   {
6739                     length = error_mark_node;
6740                     break;
6741                   }
6742
6743                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6744                                    ffecom_f2c_ftnlen_one_node,
6745                                    ffecom_2 (MINUS_EXPR,
6746                                              ffecom_f2c_ftnlen_type_node,
6747                                              end_tree, start_tree));
6748               }
6749           }
6750       }
6751       break;
6752
6753     case FFEBLD_opCONCATENATE:
6754       length
6755         = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6756                     ffecom_intrinsic_len_ (ffebld_left (expr)),
6757                     ffecom_intrinsic_len_ (ffebld_right (expr)));
6758       break;
6759
6760     case FFEBLD_opFUNCREF:
6761     case FFEBLD_opCONVERT:
6762       length = build_int_2 (ffebld_size (expr), 0);
6763       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6764       break;
6765
6766     default:
6767       assert ("bad op for single char arg expr" == NULL);
6768       length = ffecom_f2c_ftnlen_zero_node;
6769       break;
6770     }
6771
6772   assert (length != NULL_TREE);
6773
6774   return length;
6775 }
6776
6777 #endif
6778 /* Handle CHARACTER assignments.
6779
6780    Generates code to do the assignment.  Used by ordinary assignment
6781    statement handler ffecom_let_stmt and by statement-function
6782    handler to generate code for a statement function.  */
6783
6784 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6785 static void
6786 ffecom_let_char_ (tree dest_tree, tree dest_length,
6787                   ffetargetCharacterSize dest_size, ffebld source)
6788 {
6789   ffecomConcatList_ catlist;
6790   tree source_length;
6791   tree source_tree;
6792   tree expr_tree;
6793
6794   if ((dest_tree == error_mark_node)
6795       || (dest_length == error_mark_node))
6796     return;
6797
6798   assert (dest_tree != NULL_TREE);
6799   assert (dest_length != NULL_TREE);
6800
6801   /* Source might be an opCONVERT, which just means it is a different size
6802      than the destination.  Since the underlying implementation here handles
6803      that (directly or via the s_copy or s_cat run-time-library functions),
6804      we don't need the "convenience" of an opCONVERT that tells us to
6805      truncate or blank-pad, particularly since the resulting implementation
6806      would probably be slower than otherwise. */
6807
6808   while (ffebld_op (source) == FFEBLD_opCONVERT)
6809     source = ffebld_left (source);
6810
6811   catlist = ffecom_concat_list_new_ (source, dest_size);
6812   switch (ffecom_concat_list_count_ (catlist))
6813     {
6814     case 0:                     /* Shouldn't happen, but in case it does... */
6815       ffecom_concat_list_kill_ (catlist);
6816       source_tree = null_pointer_node;
6817       source_length = ffecom_f2c_ftnlen_zero_node;
6818       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6819       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6820       TREE_CHAIN (TREE_CHAIN (expr_tree))
6821         = build_tree_list (NULL_TREE, dest_length);
6822       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6823         = build_tree_list (NULL_TREE, source_length);
6824
6825       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6826       TREE_SIDE_EFFECTS (expr_tree) = 1;
6827
6828       expand_expr_stmt (expr_tree);
6829
6830       return;
6831
6832     case 1:                     /* The (fairly) easy case. */
6833       ffecom_char_args_ (&source_tree, &source_length,
6834                          ffecom_concat_list_expr_ (catlist, 0));
6835       ffecom_concat_list_kill_ (catlist);
6836       assert (source_tree != NULL_TREE);
6837       assert (source_length != NULL_TREE);
6838
6839       if ((source_tree == error_mark_node)
6840           || (source_length == error_mark_node))
6841         return;
6842
6843       if (dest_size == 1)
6844         {
6845           dest_tree
6846             = ffecom_1 (INDIRECT_REF,
6847                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6848                                                       (dest_tree))),
6849                         dest_tree);
6850           dest_tree
6851             = ffecom_2 (ARRAY_REF,
6852                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6853                                                       (dest_tree))),
6854                         dest_tree,
6855                         integer_one_node);
6856           source_tree
6857             = ffecom_1 (INDIRECT_REF,
6858                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6859                                                       (source_tree))),
6860                         source_tree);
6861           source_tree
6862             = ffecom_2 (ARRAY_REF,
6863                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6864                                                       (source_tree))),
6865                         source_tree,
6866                         integer_one_node);
6867
6868           expr_tree = ffecom_modify (void_type_node, dest_tree, source_tree);
6869
6870           expand_expr_stmt (expr_tree);
6871
6872           return;
6873         }
6874
6875       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6876       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6877       TREE_CHAIN (TREE_CHAIN (expr_tree))
6878         = build_tree_list (NULL_TREE, dest_length);
6879       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6880         = build_tree_list (NULL_TREE, source_length);
6881
6882       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6883       TREE_SIDE_EFFECTS (expr_tree) = 1;
6884
6885       expand_expr_stmt (expr_tree);
6886
6887       return;
6888
6889     default:                    /* Must actually concatenate things. */
6890       break;
6891     }
6892
6893   /* Heavy-duty concatenation. */
6894
6895   {
6896     int count = ffecom_concat_list_count_ (catlist);
6897     int i;
6898     tree lengths;
6899     tree items;
6900     tree length_array;
6901     tree item_array;
6902     tree citem;
6903     tree clength;
6904
6905 #ifdef HOHO
6906     length_array
6907       = lengths
6908       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
6909                              FFETARGET_charactersizeNONE, count, TRUE);
6910     item_array = items = ffecom_push_tempvar (ffecom_f2c_address_type_node,
6911                                               FFETARGET_charactersizeNONE,
6912                                               count, TRUE);
6913 #else
6914     {
6915       tree hook;
6916
6917       hook = ffebld_nonter_hook (source);
6918       assert (hook);
6919       assert (TREE_CODE (hook) == TREE_VEC);
6920       assert (TREE_VEC_LENGTH (hook) == 2);
6921       length_array = lengths = TREE_VEC_ELT (hook, 0);
6922       item_array = items = TREE_VEC_ELT (hook, 1);
6923     }
6924 #endif
6925
6926     for (i = 0; i < count; ++i)
6927       {
6928         ffecom_char_args_ (&citem, &clength,
6929                            ffecom_concat_list_expr_ (catlist, i));
6930         if ((citem == error_mark_node)
6931             || (clength == error_mark_node))
6932           {
6933             ffecom_concat_list_kill_ (catlist);
6934             return;
6935           }
6936
6937         items
6938           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
6939                       ffecom_modify (void_type_node,
6940                                      ffecom_2 (ARRAY_REF,
6941                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
6942                                                item_array,
6943                                                build_int_2 (i, 0)),
6944                                      citem),
6945                       items);
6946         lengths
6947           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
6948                       ffecom_modify (void_type_node,
6949                                      ffecom_2 (ARRAY_REF,
6950                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
6951                                                length_array,
6952                                                build_int_2 (i, 0)),
6953                                      clength),
6954                       lengths);
6955       }
6956
6957     expr_tree = build_tree_list (NULL_TREE, dest_tree);
6958     TREE_CHAIN (expr_tree)
6959       = build_tree_list (NULL_TREE,
6960                          ffecom_1 (ADDR_EXPR,
6961                                    build_pointer_type (TREE_TYPE (items)),
6962                                    items));
6963     TREE_CHAIN (TREE_CHAIN (expr_tree))
6964       = build_tree_list (NULL_TREE,
6965                          ffecom_1 (ADDR_EXPR,
6966                                    build_pointer_type (TREE_TYPE (lengths)),
6967                                    lengths));
6968     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6969       = build_tree_list
6970         (NULL_TREE,
6971          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
6972                    convert (ffecom_f2c_ftnlen_type_node,
6973                             build_int_2 (count, 0))));
6974     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))))
6975       = build_tree_list (NULL_TREE, dest_length);
6976
6977     expr_tree = ffecom_call_gfrt (FFECOM_gfrtCAT, expr_tree, NULL_TREE);
6978     TREE_SIDE_EFFECTS (expr_tree) = 1;
6979
6980     expand_expr_stmt (expr_tree);
6981   }
6982
6983   ffecom_concat_list_kill_ (catlist);
6984 }
6985
6986 #endif
6987 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
6988
6989    ffecomGfrt ix;
6990    ffecom_make_gfrt_(ix);
6991
6992    Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
6993    for the indicated run-time routine (ix).  */
6994
6995 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6996 static void
6997 ffecom_make_gfrt_ (ffecomGfrt ix)
6998 {
6999   tree t;
7000   tree ttype;
7001
7002   switch (ffecom_gfrt_type_[ix])
7003     {
7004     case FFECOM_rttypeVOID_:
7005       ttype = void_type_node;
7006       break;
7007
7008     case FFECOM_rttypeVOIDSTAR_:
7009       ttype = TREE_TYPE (null_pointer_node);    /* `void *'. */
7010       break;
7011
7012     case FFECOM_rttypeFTNINT_:
7013       ttype = ffecom_f2c_ftnint_type_node;
7014       break;
7015
7016     case FFECOM_rttypeINTEGER_:
7017       ttype = ffecom_f2c_integer_type_node;
7018       break;
7019
7020     case FFECOM_rttypeLONGINT_:
7021       ttype = ffecom_f2c_longint_type_node;
7022       break;
7023
7024     case FFECOM_rttypeLOGICAL_:
7025       ttype = ffecom_f2c_logical_type_node;
7026       break;
7027
7028     case FFECOM_rttypeREAL_F2C_:
7029       ttype = double_type_node;
7030       break;
7031
7032     case FFECOM_rttypeREAL_GNU_:
7033       ttype = float_type_node;
7034       break;
7035
7036     case FFECOM_rttypeCOMPLEX_F2C_:
7037       ttype = void_type_node;
7038       break;
7039
7040     case FFECOM_rttypeCOMPLEX_GNU_:
7041       ttype = ffecom_f2c_complex_type_node;
7042       break;
7043
7044     case FFECOM_rttypeDOUBLE_:
7045       ttype = double_type_node;
7046       break;
7047
7048     case FFECOM_rttypeDOUBLEREAL_:
7049       ttype = ffecom_f2c_doublereal_type_node;
7050       break;
7051
7052     case FFECOM_rttypeDBLCMPLX_F2C_:
7053       ttype = void_type_node;
7054       break;
7055
7056     case FFECOM_rttypeDBLCMPLX_GNU_:
7057       ttype = ffecom_f2c_doublecomplex_type_node;
7058       break;
7059
7060     case FFECOM_rttypeCHARACTER_:
7061       ttype = void_type_node;
7062       break;
7063
7064     default:
7065       ttype = NULL;
7066       assert ("bad rttype" == NULL);
7067       break;
7068     }
7069
7070   ttype = build_function_type (ttype, NULL_TREE);
7071   t = build_decl (FUNCTION_DECL,
7072                   get_identifier (ffecom_gfrt_name_[ix]),
7073                   ttype);
7074   DECL_EXTERNAL (t) = 1;
7075   TREE_PUBLIC (t) = 1;
7076   TREE_THIS_VOLATILE (t) = ffecom_gfrt_volatile_[ix] ? 1 : 0;
7077
7078   t = start_decl (t, TRUE);
7079
7080   finish_decl (t, NULL_TREE, TRUE);
7081
7082   ffecom_gfrt_[ix] = t;
7083 }
7084
7085 #endif
7086 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group.  */
7087
7088 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7089 static void
7090 ffecom_member_phase1_ (ffestorag mst UNUSED, ffestorag st)
7091 {
7092   ffesymbol s = ffestorag_symbol (st);
7093
7094   if (ffesymbol_namelisted (s))
7095     ffecom_member_namelisted_ = TRUE;
7096 }
7097
7098 #endif
7099 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group.  Declare
7100    the member so debugger will see it.  Otherwise nobody should be
7101    referencing the member.  */
7102
7103 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7104 static void
7105 ffecom_member_phase2_ (ffestorag mst, ffestorag st)
7106 {
7107   ffesymbol s;
7108   tree t;
7109   tree mt;
7110   tree type;
7111
7112   if ((mst == NULL)
7113       || ((mt = ffestorag_hook (mst)) == NULL)
7114       || (mt == error_mark_node))
7115     return;
7116
7117   if ((st == NULL)
7118       || ((s = ffestorag_symbol (st)) == NULL))
7119     return;
7120
7121   type = ffecom_type_localvar_ (s,
7122                                 ffesymbol_basictype (s),
7123                                 ffesymbol_kindtype (s));
7124   if (type == error_mark_node)
7125     return;
7126
7127   t = build_decl (VAR_DECL,
7128                   ffecom_get_identifier_ (ffesymbol_text (s)),
7129                   type);
7130
7131   TREE_STATIC (t) = TREE_STATIC (mt);
7132   DECL_INITIAL (t) = NULL_TREE;
7133   TREE_ASM_WRITTEN (t) = 1;
7134
7135   DECL_RTL (t)
7136     = gen_rtx (MEM, TYPE_MODE (type),
7137                plus_constant (XEXP (DECL_RTL (mt), 0),
7138                               ffestorag_modulo (mst)
7139                               + ffestorag_offset (st)
7140                               - ffestorag_offset (mst)));
7141
7142   t = start_decl (t, FALSE);
7143
7144   finish_decl (t, NULL_TREE, FALSE);
7145 }
7146
7147 #endif
7148 /* Prepare source expression for assignment into a destination perhaps known
7149    to be of a specific size.  */
7150
7151 static void
7152 ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size, ffebld source)
7153 {
7154   ffecomConcatList_ catlist;
7155   int count;
7156   int i;
7157   tree ltmp;
7158   tree itmp;
7159   tree tempvar = NULL_TREE;
7160
7161   while (ffebld_op (source) == FFEBLD_opCONVERT)
7162     source = ffebld_left (source);
7163
7164   catlist = ffecom_concat_list_new_ (source, dest_size);
7165   count = ffecom_concat_list_count_ (catlist);
7166
7167   if (count >= 2)
7168     {
7169       ltmp
7170         = ffecom_make_tempvar ("let_char_len", ffecom_f2c_ftnlen_type_node,
7171                                FFETARGET_charactersizeNONE, count);
7172       itmp
7173         = ffecom_make_tempvar ("let_char_item", ffecom_f2c_address_type_node,
7174                                FFETARGET_charactersizeNONE, count);
7175
7176       tempvar = make_tree_vec (2);
7177       TREE_VEC_ELT (tempvar, 0) = ltmp;
7178       TREE_VEC_ELT (tempvar, 1) = itmp;
7179     }
7180
7181   for (i = 0; i < count; ++i)
7182     ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist, i));
7183
7184   ffecom_concat_list_kill_ (catlist);
7185
7186   if (tempvar)
7187     {
7188       ffebld_nonter_set_hook (source, tempvar);
7189       current_binding_level->prep_state = 1;
7190     }
7191 }
7192
7193 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
7194
7195    Ignores STAR (alternate-return) dummies.  All other get exec-transitioned
7196    (which generates their trees) and then their trees get push_parm_decl'd.
7197
7198    The second arg is TRUE if the dummies are for a statement function, in
7199    which case lengths are not pushed for character arguments (since they are
7200    always known by both the caller and the callee, though the code allows
7201    for someday permitting CHAR*(*) stmtfunc dummies).  */
7202
7203 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7204 static void
7205 ffecom_push_dummy_decls_ (ffebld dummy_list, bool stmtfunc)
7206 {
7207   ffebld dummy;
7208   ffebld dumlist;
7209   ffesymbol s;
7210   tree parm;
7211
7212   ffecom_transform_only_dummies_ = TRUE;
7213
7214   /* First push the parms corresponding to actual dummy "contents".  */
7215
7216   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7217     {
7218       dummy = ffebld_head (dumlist);
7219       switch (ffebld_op (dummy))
7220         {
7221         case FFEBLD_opSTAR:
7222         case FFEBLD_opANY:
7223           continue;             /* Forget alternate returns. */
7224
7225         default:
7226           break;
7227         }
7228       assert (ffebld_op (dummy) == FFEBLD_opSYMTER);
7229       s = ffebld_symter (dummy);
7230       parm = ffesymbol_hook (s).decl_tree;
7231       if (parm == NULL_TREE)
7232         {
7233           s = ffecom_sym_transform_ (s);
7234           parm = ffesymbol_hook (s).decl_tree;
7235           assert (parm != NULL_TREE);
7236         }
7237       if (parm != error_mark_node)
7238         push_parm_decl (parm);
7239     }
7240
7241   /* Then, for CHARACTER dummies, push the parms giving their lengths.  */
7242
7243   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7244     {
7245       dummy = ffebld_head (dumlist);
7246       switch (ffebld_op (dummy))
7247         {
7248         case FFEBLD_opSTAR:
7249         case FFEBLD_opANY:
7250           continue;             /* Forget alternate returns, they mean
7251                                    NOTHING! */
7252
7253         default:
7254           break;
7255         }
7256       s = ffebld_symter (dummy);
7257       if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
7258         continue;               /* Only looking for CHARACTER arguments. */
7259       if (stmtfunc && (ffesymbol_size (s) != FFETARGET_charactersizeNONE))
7260         continue;               /* Stmtfunc arg with known size needs no
7261                                    length param. */
7262       if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
7263         continue;               /* Only looking for variables and arrays. */
7264       parm = ffesymbol_hook (s).length_tree;
7265       assert (parm != NULL_TREE);
7266       if (parm != error_mark_node)
7267         push_parm_decl (parm);
7268     }
7269
7270   ffecom_transform_only_dummies_ = FALSE;
7271 }
7272
7273 #endif
7274 /* ffecom_start_progunit_ -- Beginning of program unit
7275
7276    Does GNU back end stuff necessary to teach it about the start of its
7277    equivalent of a Fortran program unit.  */
7278
7279 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7280 static void
7281 ffecom_start_progunit_ ()
7282 {
7283   ffesymbol fn = ffecom_primary_entry_;
7284   ffebld arglist;
7285   tree id;                      /* Identifier (name) of function. */
7286   tree type;                    /* Type of function. */
7287   tree result;                  /* Result of function. */
7288   ffeinfoBasictype bt;
7289   ffeinfoKindtype kt;
7290   ffeglobal g;
7291   ffeglobalType gt;
7292   ffeglobalType egt = FFEGLOBAL_type;
7293   bool charfunc;
7294   bool cmplxfunc;
7295   bool altentries = (ffecom_num_entrypoints_ != 0);
7296   bool multi
7297   = altentries
7298   && (ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
7299   && (ffecom_master_bt_ == FFEINFO_basictypeNONE);
7300   bool main_program = FALSE;
7301   int old_lineno = lineno;
7302   char *old_input_filename = input_filename;
7303   int yes;
7304
7305   assert (fn != NULL);
7306   assert (ffesymbol_hook (fn).decl_tree == NULL_TREE);
7307
7308   input_filename = ffesymbol_where_filename (fn);
7309   lineno = ffesymbol_where_filelinenum (fn);
7310
7311   /* c-parse.y indeed does call suspend_momentary and not only ignores the
7312      return value, but also never calls resume_momentary, when starting an
7313      outer function (see "fndef:", "setspecs:", and so on).  So g77 does the
7314      same thing.  It shouldn't be a problem since start_function calls
7315      temporary_allocation, but it might be necessary.  If it causes a problem
7316      here, then maybe there's a bug lurking in gcc.  NOTE: This identical
7317      comment appears twice in thist file.  */
7318
7319   suspend_momentary ();
7320
7321   switch (ffecom_primary_entry_kind_)
7322     {
7323     case FFEINFO_kindPROGRAM:
7324       main_program = TRUE;
7325       gt = FFEGLOBAL_typeMAIN;
7326       bt = FFEINFO_basictypeNONE;
7327       kt = FFEINFO_kindtypeNONE;
7328       type = ffecom_tree_fun_type_void;
7329       charfunc = FALSE;
7330       cmplxfunc = FALSE;
7331       break;
7332
7333     case FFEINFO_kindBLOCKDATA:
7334       gt = FFEGLOBAL_typeBDATA;
7335       bt = FFEINFO_basictypeNONE;
7336       kt = FFEINFO_kindtypeNONE;
7337       type = ffecom_tree_fun_type_void;
7338       charfunc = FALSE;
7339       cmplxfunc = FALSE;
7340       break;
7341
7342     case FFEINFO_kindFUNCTION:
7343       gt = FFEGLOBAL_typeFUNC;
7344       egt = FFEGLOBAL_typeEXT;
7345       bt = ffesymbol_basictype (fn);
7346       kt = ffesymbol_kindtype (fn);
7347       if (bt == FFEINFO_basictypeNONE)
7348         {
7349           ffeimplic_establish_symbol (fn);
7350           if (ffesymbol_funcresult (fn) != NULL)
7351             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
7352           bt = ffesymbol_basictype (fn);
7353           kt = ffesymbol_kindtype (fn);
7354         }
7355
7356       if (multi)
7357         charfunc = cmplxfunc = FALSE;
7358       else if (bt == FFEINFO_basictypeCHARACTER)
7359         charfunc = TRUE, cmplxfunc = FALSE;
7360       else if ((bt == FFEINFO_basictypeCOMPLEX)
7361                && ffesymbol_is_f2c (fn)
7362                && !altentries)
7363         charfunc = FALSE, cmplxfunc = TRUE;
7364       else
7365         charfunc = cmplxfunc = FALSE;
7366
7367       if (multi || charfunc)
7368         type = ffecom_tree_fun_type_void;
7369       else if (ffesymbol_is_f2c (fn) && !altentries)
7370         type = ffecom_tree_fun_type[bt][kt];
7371       else
7372         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
7373
7374       if ((type == NULL_TREE)
7375           || (TREE_TYPE (type) == NULL_TREE))
7376         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
7377       break;
7378
7379     case FFEINFO_kindSUBROUTINE:
7380       gt = FFEGLOBAL_typeSUBR;
7381       egt = FFEGLOBAL_typeEXT;
7382       bt = FFEINFO_basictypeNONE;
7383       kt = FFEINFO_kindtypeNONE;
7384       if (ffecom_is_altreturning_)
7385         type = ffecom_tree_subr_type;
7386       else
7387         type = ffecom_tree_fun_type_void;
7388       charfunc = FALSE;
7389       cmplxfunc = FALSE;
7390       break;
7391
7392     default:
7393       assert ("say what??" == NULL);
7394       /* Fall through. */
7395     case FFEINFO_kindANY:
7396       gt = FFEGLOBAL_typeANY;
7397       bt = FFEINFO_basictypeNONE;
7398       kt = FFEINFO_kindtypeNONE;
7399       type = error_mark_node;
7400       charfunc = FALSE;
7401       cmplxfunc = FALSE;
7402       break;
7403     }
7404
7405   if (altentries)
7406     {
7407       id = ffecom_get_invented_identifier ("__g77_masterfun_%s",
7408                                            ffesymbol_text (fn));
7409     }
7410 #if FFETARGET_isENFORCED_MAIN
7411   else if (main_program)
7412     id = get_identifier (FFETARGET_nameENFORCED_MAIN_NAME);
7413 #endif
7414   else
7415     id = ffecom_get_external_identifier_ (fn);
7416
7417   start_function (id,
7418                   type,
7419                   0,            /* nested/inline */
7420                   !altentries); /* TREE_PUBLIC */
7421
7422   TREE_USED (current_function_decl) = 1;        /* Avoid spurious warning if altentries. */
7423
7424   if (!altentries
7425       && ((g = ffesymbol_global (fn)) != NULL)
7426       && ((ffeglobal_type (g) == gt)
7427           || (ffeglobal_type (g) == egt)))
7428     {
7429       ffeglobal_set_hook (g, current_function_decl);
7430     }
7431
7432   yes = suspend_momentary ();
7433
7434   /* Arg handling needs exec-transitioned ffesymbols to work with.  But
7435      exec-transitioning needs current_function_decl to be filled in.  So we
7436      do these things in two phases. */
7437
7438   if (altentries)
7439     {                           /* 1st arg identifies which entrypoint. */
7440       ffecom_which_entrypoint_decl_
7441         = build_decl (PARM_DECL,
7442                       ffecom_get_invented_identifier ("__g77_%s",
7443                                                       "which_entrypoint"),
7444                       integer_type_node);
7445       push_parm_decl (ffecom_which_entrypoint_decl_);
7446     }
7447
7448   if (charfunc
7449       || cmplxfunc
7450       || multi)
7451     {                           /* Arg for result (return value). */
7452       tree type;
7453       tree length;
7454
7455       if (charfunc)
7456         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
7457       else if (cmplxfunc)
7458         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
7459       else
7460         type = ffecom_multi_type_node_;
7461
7462       result = ffecom_get_invented_identifier ("__g77_%s", "result");
7463
7464       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
7465
7466       if (charfunc)
7467         length = ffecom_char_enhance_arg_ (&type, fn);
7468       else
7469         length = NULL_TREE;     /* Not ref'd if !charfunc. */
7470
7471       type = build_pointer_type (type);
7472       result = build_decl (PARM_DECL, result, type);
7473
7474       push_parm_decl (result);
7475       if (multi)
7476         ffecom_multi_retval_ = result;
7477       else
7478         ffecom_func_result_ = result;
7479
7480       if (charfunc)
7481         {
7482           push_parm_decl (length);
7483           ffecom_func_length_ = length;
7484         }
7485     }
7486
7487   if (ffecom_primary_entry_is_proc_)
7488     {
7489       if (altentries)
7490         arglist = ffecom_master_arglist_;
7491       else
7492         arglist = ffesymbol_dummyargs (fn);
7493       ffecom_push_dummy_decls_ (arglist, FALSE);
7494     }
7495
7496   resume_momentary (yes);
7497
7498   if (TREE_CODE (current_function_decl) != ERROR_MARK)
7499     store_parm_decls (main_program ? 1 : 0);
7500
7501   ffecom_start_compstmt ();
7502   /* Disallow temp vars at this level.  */
7503   current_binding_level->prep_state = 2;
7504
7505   lineno = old_lineno;
7506   input_filename = old_input_filename;
7507
7508   /* This handles any symbols still untransformed, in case -g specified.
7509      This used to be done in ffecom_finish_progunit, but it turns out to
7510      be necessary to do it here so that statement functions are
7511      expanded before code.  But don't bother for BLOCK DATA.  */
7512
7513   if (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
7514     ffesymbol_drive (ffecom_finish_symbol_transform_);
7515 }
7516
7517 #endif
7518 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
7519
7520    ffesymbol s;
7521    ffecom_sym_transform_(s);
7522
7523    The ffesymbol_hook info for s is updated with appropriate backend info
7524    on the symbol.  */
7525
7526 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7527 static ffesymbol
7528 ffecom_sym_transform_ (ffesymbol s)
7529 {
7530   tree t;                       /* Transformed thingy. */
7531   tree tlen;                    /* Length if CHAR*(*). */
7532   bool addr;                    /* Is t the address of the thingy? */
7533   ffeinfoBasictype bt;
7534   ffeinfoKindtype kt;
7535   ffeglobal g;
7536   int yes;
7537   int old_lineno = lineno;
7538   char *old_input_filename = input_filename;
7539
7540   /* Must ensure special ASSIGN variables are declared at top of outermost
7541      block, else they'll end up in the innermost block when their first
7542      ASSIGN is seen, which leaves them out of scope when they're the
7543      subject of a GOTO or I/O statement.
7544
7545      We make this variable even if -fugly-assign.  Just let it go unused,
7546      in case it turns out there are cases where we really want to use this
7547      variable anyway (e.g. ASSIGN to INTEGER*2 variable).  */
7548
7549   if (! ffecom_transform_only_dummies_
7550       && ffesymbol_assigned (s)
7551       && ! ffesymbol_hook (s).assign_tree)
7552     s = ffecom_sym_transform_assign_ (s);
7553
7554   if (ffesymbol_sfdummyparent (s) == NULL)
7555     {
7556       input_filename = ffesymbol_where_filename (s);
7557       lineno = ffesymbol_where_filelinenum (s);
7558     }
7559   else
7560     {
7561       ffesymbol sf = ffesymbol_sfdummyparent (s);
7562
7563       input_filename = ffesymbol_where_filename (sf);
7564       lineno = ffesymbol_where_filelinenum (sf);
7565     }
7566
7567   bt = ffeinfo_basictype (ffebld_info (s));
7568   kt = ffeinfo_kindtype (ffebld_info (s));
7569
7570   t = NULL_TREE;
7571   tlen = NULL_TREE;
7572   addr = FALSE;
7573
7574   switch (ffesymbol_kind (s))
7575     {
7576     case FFEINFO_kindNONE:
7577       switch (ffesymbol_where (s))
7578         {
7579         case FFEINFO_whereDUMMY:        /* Subroutine or function. */
7580           assert (ffecom_transform_only_dummies_);
7581
7582           /* Before 0.4, this could be ENTITY/DUMMY, but see
7583              ffestu_sym_end_transition -- no longer true (in particular, if
7584              it could be an ENTITY, it _will_ be made one, so that
7585              possibility won't come through here).  So we never make length
7586              arg for CHARACTER type.  */
7587
7588           t = build_decl (PARM_DECL,
7589                           ffecom_get_identifier_ (ffesymbol_text (s)),
7590                           ffecom_tree_ptr_to_subr_type);
7591 #if BUILT_FOR_270
7592           DECL_ARTIFICIAL (t) = 1;
7593 #endif
7594           addr = TRUE;
7595           break;
7596
7597         case FFEINFO_whereGLOBAL:       /* Subroutine or function. */
7598           assert (!ffecom_transform_only_dummies_);
7599
7600           if (((g = ffesymbol_global (s)) != NULL)
7601               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7602                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7603                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
7604               && (ffeglobal_hook (g) != NULL_TREE)
7605               && ffe_is_globals ())
7606             {
7607               t = ffeglobal_hook (g);
7608               break;
7609             }
7610
7611           t = build_decl (FUNCTION_DECL,
7612                           ffecom_get_external_identifier_ (s),
7613                           ffecom_tree_subr_type);       /* Assume subr. */
7614           DECL_EXTERNAL (t) = 1;
7615           TREE_PUBLIC (t) = 1;
7616
7617           t = start_decl (t, FALSE);
7618           finish_decl (t, NULL_TREE, FALSE);
7619
7620           if ((g != NULL)
7621               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7622                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7623                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
7624             ffeglobal_set_hook (g, t);
7625
7626           ffecom_save_tree_forever (t);
7627
7628           break;
7629
7630         default:
7631           assert ("NONE where unexpected" == NULL);
7632           /* Fall through. */
7633         case FFEINFO_whereANY:
7634           break;
7635         }
7636       break;
7637
7638     case FFEINFO_kindENTITY:
7639       switch (ffeinfo_where (ffesymbol_info (s)))
7640         {
7641
7642         case FFEINFO_whereCONSTANT:
7643           /* ~~Debugging info needed? */
7644           assert (!ffecom_transform_only_dummies_);
7645           t = error_mark_node;  /* Shouldn't ever see this in expr. */
7646           break;
7647
7648         case FFEINFO_whereLOCAL:
7649           assert (!ffecom_transform_only_dummies_);
7650
7651           {
7652             ffestorag st = ffesymbol_storage (s);
7653             tree type;
7654
7655             if ((st != NULL)
7656                 && (ffestorag_size (st) == 0))
7657               {
7658                 t = error_mark_node;
7659                 break;
7660               }
7661
7662             yes = suspend_momentary ();
7663             type = ffecom_type_localvar_ (s, bt, kt);
7664             resume_momentary (yes);
7665
7666             if (type == error_mark_node)
7667               {
7668                 t = error_mark_node;
7669                 break;
7670               }
7671
7672             if ((st != NULL)
7673                 && (ffestorag_parent (st) != NULL))
7674               {                 /* Child of EQUIVALENCE parent. */
7675                 ffestorag est;
7676                 tree et;
7677                 int yes;
7678                 ffetargetOffset offset;
7679
7680                 est = ffestorag_parent (st);
7681                 ffecom_transform_equiv_ (est);
7682
7683                 et = ffestorag_hook (est);
7684                 assert (et != NULL_TREE);
7685
7686                 if (! TREE_STATIC (et))
7687                   put_var_into_stack (et);
7688
7689                 yes = suspend_momentary ();
7690
7691                 offset = ffestorag_modulo (est)
7692                   + ffestorag_offset (ffesymbol_storage (s))
7693                   - ffestorag_offset (est);
7694
7695                 ffecom_debug_kludge_ (et, "EQUIVALENCE", s, type, offset);
7696
7697                 /* (t_type *) (((char *) &et) + offset) */
7698
7699                 t = convert (string_type_node,  /* (char *) */
7700                              ffecom_1 (ADDR_EXPR,
7701                                        build_pointer_type (TREE_TYPE (et)),
7702                                        et));
7703                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
7704                               t,
7705                               build_int_2 (offset, 0));
7706                 t = convert (build_pointer_type (type),
7707                              t);
7708                 TREE_CONSTANT (t) = staticp (et);
7709
7710                 addr = TRUE;
7711
7712                 resume_momentary (yes);
7713               }
7714             else
7715               {
7716                 tree initexpr;
7717                 bool init = ffesymbol_is_init (s);
7718
7719                 yes = suspend_momentary ();
7720
7721                 t = build_decl (VAR_DECL,
7722                                 ffecom_get_identifier_ (ffesymbol_text (s)),
7723                                 type);
7724
7725                 if (init
7726                     || ffesymbol_namelisted (s)
7727 #ifdef FFECOM_sizeMAXSTACKITEM
7728                     || ((st != NULL)
7729                         && (ffestorag_size (st) > FFECOM_sizeMAXSTACKITEM))
7730 #endif
7731                     || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
7732                         && (ffecom_primary_entry_kind_
7733                             != FFEINFO_kindBLOCKDATA)
7734                         && (ffesymbol_is_save (s) || ffe_is_saveall ())))
7735                   TREE_STATIC (t) = !ffesymbol_attr (s, FFESYMBOL_attrADJUSTABLE);
7736                 else
7737                   TREE_STATIC (t) = 0;  /* No need to make static. */
7738
7739                 if (init || ffe_is_init_local_zero ())
7740                   DECL_INITIAL (t) = error_mark_node;
7741
7742                 /* Keep -Wunused from complaining about var if it
7743                    is used as sfunc arg or DATA implied-DO.  */
7744                 if (ffesymbol_attrs (s) & FFESYMBOL_attrsSFARG)
7745                   DECL_IN_SYSTEM_HEADER (t) = 1;
7746
7747                 t = start_decl (t, FALSE);
7748
7749                 if (init)
7750                   {
7751                     if (ffesymbol_init (s) != NULL)
7752                       initexpr = ffecom_expr (ffesymbol_init (s));
7753                     else
7754                       initexpr = ffecom_init_zero_ (t);
7755                   }
7756                 else if (ffe_is_init_local_zero ())
7757                   initexpr = ffecom_init_zero_ (t);
7758                 else
7759                   initexpr = NULL_TREE; /* Not ref'd if !init. */
7760
7761                 finish_decl (t, initexpr, FALSE);
7762
7763                 if (st != NULL && DECL_SIZE (t) != error_mark_node)
7764                   {
7765                     assert (TREE_CODE (DECL_SIZE_UNIT (t)) == INTEGER_CST);
7766                     assert (TREE_INT_CST_HIGH (DECL_SIZE_UNIT (t)) == 0);
7767                     assert (TREE_INT_CST_LOW (DECL_SIZE_UNIT (t))
7768                             == ffestorag_size (st));
7769                   }
7770
7771                 resume_momentary (yes);
7772               }
7773           }
7774           break;
7775
7776         case FFEINFO_whereRESULT:
7777           assert (!ffecom_transform_only_dummies_);
7778
7779           if (bt == FFEINFO_basictypeCHARACTER)
7780             {                   /* Result is already in list of dummies, use
7781                                    it (& length). */
7782               t = ffecom_func_result_;
7783               tlen = ffecom_func_length_;
7784               addr = TRUE;
7785               break;
7786             }
7787           if ((ffecom_num_entrypoints_ == 0)
7788               && (bt == FFEINFO_basictypeCOMPLEX)
7789               && (ffesymbol_is_f2c (ffecom_primary_entry_)))
7790             {                   /* Result is already in list of dummies, use
7791                                    it. */
7792               t = ffecom_func_result_;
7793               addr = TRUE;
7794               break;
7795             }
7796           if (ffecom_func_result_ != NULL_TREE)
7797             {
7798               t = ffecom_func_result_;
7799               break;
7800             }
7801           if ((ffecom_num_entrypoints_ != 0)
7802               && (ffecom_master_bt_ == FFEINFO_basictypeNONE))
7803             {
7804               yes = suspend_momentary ();
7805
7806               assert (ffecom_multi_retval_ != NULL_TREE);
7807               t = ffecom_1 (INDIRECT_REF, ffecom_multi_type_node_,
7808                             ffecom_multi_retval_);
7809               t = ffecom_2 (COMPONENT_REF, ffecom_tree_type[bt][kt],
7810                             t, ffecom_multi_fields_[bt][kt]);
7811
7812               resume_momentary (yes);
7813               break;
7814             }
7815
7816           yes = suspend_momentary ();
7817
7818           t = build_decl (VAR_DECL,
7819                           ffecom_get_identifier_ (ffesymbol_text (s)),
7820                           ffecom_tree_type[bt][kt]);
7821           TREE_STATIC (t) = 0;  /* Put result on stack. */
7822           t = start_decl (t, FALSE);
7823           finish_decl (t, NULL_TREE, FALSE);
7824
7825           ffecom_func_result_ = t;
7826
7827           resume_momentary (yes);
7828           break;
7829
7830         case FFEINFO_whereDUMMY:
7831           {
7832             tree type;
7833             ffebld dl;
7834             ffebld dim;
7835             tree low;
7836             tree high;
7837             tree old_sizes;
7838             bool adjustable = FALSE;    /* Conditionally adjustable? */
7839
7840             type = ffecom_tree_type[bt][kt];
7841             if (ffesymbol_sfdummyparent (s) != NULL)
7842               {
7843                 if (current_function_decl == ffecom_outer_function_decl_)
7844                   {                     /* Exec transition before sfunc
7845                                            context; get it later. */
7846                     break;
7847                   }
7848                 t = ffecom_get_identifier_ (ffesymbol_text
7849                                             (ffesymbol_sfdummyparent (s)));
7850               }
7851             else
7852               t = ffecom_get_identifier_ (ffesymbol_text (s));
7853
7854             assert (ffecom_transform_only_dummies_);
7855
7856             old_sizes = get_pending_sizes ();
7857             put_pending_sizes (old_sizes);
7858
7859             if (bt == FFEINFO_basictypeCHARACTER)
7860               tlen = ffecom_char_enhance_arg_ (&type, s);
7861             type = ffecom_check_size_overflow_ (s, type, TRUE);
7862
7863             for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
7864               {
7865                 if (type == error_mark_node)
7866                   break;
7867
7868                 dim = ffebld_head (dl);
7869                 assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
7870                 if ((ffebld_left (dim) == NULL) || ffecom_doing_entry_)
7871                   low = ffecom_integer_one_node;
7872                 else
7873                   low = ffecom_expr (ffebld_left (dim));
7874                 assert (ffebld_right (dim) != NULL);
7875                 if ((ffebld_op (ffebld_right (dim)) == FFEBLD_opSTAR)
7876                     || ffecom_doing_entry_)
7877                   {
7878                     /* Used to just do high=low.  But for ffecom_tree_
7879                        canonize_ref_, it probably is important to correctly
7880                        assess the size.  E.g. given COMPLEX C(*),CFUNC and
7881                        C(2)=CFUNC(C), overlap can happen, while it can't
7882                        for, say, C(1)=CFUNC(C(2)).  */
7883                     /* Even more recently used to set to INT_MAX, but that
7884                        broke when some overflow checking went into the back
7885                        end.  Now we just leave the upper bound unspecified.  */
7886                     high = NULL;
7887                   }
7888                 else
7889                   high = ffecom_expr (ffebld_right (dim));
7890
7891                 /* Determine whether array is conditionally adjustable,
7892                    to decide whether back-end magic is needed.
7893
7894                    Normally the front end uses the back-end function
7895                    variable_size to wrap SAVE_EXPR's around expressions
7896                    affecting the size/shape of an array so that the
7897                    size/shape info doesn't change during execution
7898                    of the compiled code even though variables and
7899                    functions referenced in those expressions might.
7900
7901                    variable_size also makes sure those saved expressions
7902                    get evaluated immediately upon entry to the
7903                    compiled procedure -- the front end normally doesn't
7904                    have to worry about that.
7905
7906                    However, there is a problem with this that affects
7907                    g77's implementation of entry points, and that is
7908                    that it is _not_ true that each invocation of the
7909                    compiled procedure is permitted to evaluate
7910                    array size/shape info -- because it is possible
7911                    that, for some invocations, that info is invalid (in
7912                    which case it is "promised" -- i.e. a violation of
7913                    the Fortran standard -- that the compiled code
7914                    won't reference the array or its size/shape
7915                    during that particular invocation).
7916
7917                    To phrase this in C terms, consider this gcc function:
7918
7919                      void foo (int *n, float (*a)[*n])
7920                      {
7921                        // a is "pointer to array ...", fyi.
7922                      }
7923
7924                    Suppose that, for some invocations, it is permitted
7925                    for a caller of foo to do this:
7926
7927                        foo (NULL, NULL);
7928
7929                    Now the _written_ code for foo can take such a call
7930                    into account by either testing explicitly for whether
7931                    (a == NULL) || (n == NULL) -- presumably it is
7932                    not permitted to reference *a in various fashions
7933                    if (n == NULL) I suppose -- or it can avoid it by
7934                    looking at other info (other arguments, static/global
7935                    data, etc.).
7936
7937                    However, this won't work in gcc 2.5.8 because it'll
7938                    automatically emit the code to save the "*n"
7939                    expression, which'll yield a NULL dereference for
7940                    the "foo (NULL, NULL)" call, something the code
7941                    for foo cannot prevent.
7942
7943                    g77 definitely needs to avoid executing such
7944                    code anytime the pointer to the adjustable array
7945                    is NULL, because even if its bounds expressions
7946                    don't have any references to possible "absent"
7947                    variables like "*n" -- say all variable references
7948                    are to COMMON variables, i.e. global (though in C,
7949                    local static could actually make sense) -- the
7950                    expressions could yield other run-time problems
7951                    for allowably "dead" values in those variables.
7952
7953                    For example, let's consider a more complicated
7954                    version of foo:
7955
7956                      extern int i;
7957                      extern int j;
7958
7959                      void foo (float (*a)[i/j])
7960                      {
7961                        ...
7962                      }
7963
7964                    The above is (essentially) quite valid for Fortran
7965                    but, again, for a call like "foo (NULL);", it is
7966                    permitted for i and j to be undefined when the
7967                    call is made.  If j happened to be zero, for
7968                    example, emitting the code to evaluate "i/j"
7969                    could result in a run-time error.
7970
7971                    Offhand, though I don't have my F77 or F90
7972                    standards handy, it might even be valid for a
7973                    bounds expression to contain a function reference,
7974                    in which case I doubt it is permitted for an
7975                    implementation to invoke that function in the
7976                    Fortran case involved here (invocation of an
7977                    alternate ENTRY point that doesn't have the adjustable
7978                    array as one of its arguments).
7979
7980                    So, the code that the compiler would normally emit
7981                    to preevaluate the size/shape info for an
7982                    adjustable array _must not_ be executed at run time
7983                    in certain cases.  Specifically, for Fortran,
7984                    the case is when the pointer to the adjustable
7985                    array == NULL.  (For gnu-ish C, it might be nice
7986                    for the source code itself to specify an expression
7987                    that, if TRUE, inhibits execution of the code.  Or
7988                    reverse the sense for elegance.)
7989
7990                    (Note that g77 could use a different test than NULL,
7991                    actually, since it happens to always pass an
7992                    integer to the called function that specifies which
7993                    entry point is being invoked.  Hmm, this might
7994                    solve the next problem.)
7995
7996                    One way a user could, I suppose, write "foo" so
7997                    it works is to insert COND_EXPR's for the
7998                    size/shape info so the dangerous stuff isn't
7999                    actually done, as in:
8000
8001                      void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
8002                      {
8003                        ...
8004                      }
8005
8006                    The next problem is that the front end needs to
8007                    be able to tell the back end about the array's
8008                    decl _before_ it tells it about the conditional
8009                    expression to inhibit evaluation of size/shape info,
8010                    as shown above.
8011
8012                    To solve this, the front end needs to be able
8013                    to give the back end the expression to inhibit
8014                    generation of the preevaluation code _after_
8015                    it makes the decl for the adjustable array.
8016
8017                    Until then, the above example using the COND_EXPR
8018                    doesn't pass muster with gcc because the "(a == NULL)"
8019                    part has a reference to "a", which is still
8020                    undefined at that point.
8021
8022                    g77 will therefore use a different mechanism in the
8023                    meantime.  */
8024
8025                 if (!adjustable
8026                     && ((TREE_CODE (low) != INTEGER_CST)
8027                         || (high && TREE_CODE (high) != INTEGER_CST)))
8028                   adjustable = TRUE;
8029
8030 #if 0                           /* Old approach -- see below. */
8031                 if (TREE_CODE (low) != INTEGER_CST)
8032                   low = ffecom_3 (COND_EXPR, integer_type_node,
8033                                   ffecom_adjarray_passed_ (s),
8034                                   low,
8035                                   ffecom_integer_zero_node);
8036
8037                 if (high && TREE_CODE (high) != INTEGER_CST)
8038                   high = ffecom_3 (COND_EXPR, integer_type_node,
8039                                    ffecom_adjarray_passed_ (s),
8040                                    high,
8041                                    ffecom_integer_zero_node);
8042 #endif
8043
8044                 /* ~~~gcc/stor-layout.c (layout_type) should do this,
8045                    probably.  Fixes 950302-1.f.  */
8046
8047                 if (TREE_CODE (low) != INTEGER_CST)
8048                   low = variable_size (low);
8049
8050                 /* ~~~Similarly, this fixes dumb0.f.  The C front end
8051                    does this, which is why dumb0.c would work.  */
8052
8053                 if (high && TREE_CODE (high) != INTEGER_CST)
8054                   high = variable_size (high);
8055
8056                 type
8057                   = build_array_type
8058                     (type,
8059                      build_range_type (ffecom_integer_type_node,
8060                                        low, high));
8061                 type = ffecom_check_size_overflow_ (s, type, TRUE);
8062               }
8063
8064             if (type == error_mark_node)
8065               {
8066                 t = error_mark_node;
8067                 break;
8068               }
8069
8070             if ((ffesymbol_sfdummyparent (s) == NULL)
8071                  || (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
8072               {
8073                 type = build_pointer_type (type);
8074                 addr = TRUE;
8075               }
8076
8077             t = build_decl (PARM_DECL, t, type);
8078 #if BUILT_FOR_270
8079             DECL_ARTIFICIAL (t) = 1;
8080 #endif
8081
8082             /* If this arg is present in every entry point's list of
8083                dummy args, then we're done.  */
8084
8085             if (ffesymbol_numentries (s)
8086                 == (ffecom_num_entrypoints_ + 1))
8087               break;
8088
8089 #if 1
8090
8091             /* If variable_size in stor-layout has been called during
8092                the above, then get_pending_sizes should have the
8093                yet-to-be-evaluated saved expressions pending.
8094                Make the whole lot of them get emitted, conditionally
8095                on whether the array decl ("t" above) is not NULL.  */
8096
8097             {
8098               tree sizes = get_pending_sizes ();
8099               tree tem;
8100
8101               for (tem = sizes;
8102                    tem != old_sizes;
8103                    tem = TREE_CHAIN (tem))
8104                 {
8105                   tree temv = TREE_VALUE (tem);
8106
8107                   if (sizes == tem)
8108                     sizes = temv;
8109                   else
8110                     sizes
8111                       = ffecom_2 (COMPOUND_EXPR,
8112                                   TREE_TYPE (sizes),
8113                                   temv,
8114                                   sizes);
8115                 }
8116
8117               if (sizes != tem)
8118                 {
8119                   sizes
8120                     = ffecom_3 (COND_EXPR,
8121                                 TREE_TYPE (sizes),
8122                                 ffecom_2 (NE_EXPR,
8123                                           integer_type_node,
8124                                           t,
8125                                           null_pointer_node),
8126                                 sizes,
8127                                 convert (TREE_TYPE (sizes),
8128                                          integer_zero_node));
8129                   sizes = ffecom_save_tree (sizes);
8130
8131                   sizes
8132                     = tree_cons (NULL_TREE, sizes, tem);
8133                 }
8134
8135               if (sizes)
8136                 put_pending_sizes (sizes);
8137             }
8138
8139 #else
8140 #if 0
8141             if (adjustable
8142                 && (ffesymbol_numentries (s)
8143                     != ffecom_num_entrypoints_ + 1))
8144               DECL_SOMETHING (t)
8145                 = ffecom_2 (NE_EXPR, integer_type_node,
8146                             t,
8147                             null_pointer_node);
8148 #else
8149 #if 0
8150             if (adjustable
8151                 && (ffesymbol_numentries (s)
8152                     != ffecom_num_entrypoints_ + 1))
8153               {
8154                 ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED);
8155                 ffebad_here (0, ffesymbol_where_line (s),
8156                              ffesymbol_where_column (s));
8157                 ffebad_string (ffesymbol_text (s));
8158                 ffebad_finish ();
8159               }
8160 #endif
8161 #endif
8162 #endif
8163           }
8164           break;
8165
8166         case FFEINFO_whereCOMMON:
8167           {
8168             ffesymbol cs;
8169             ffeglobal cg;
8170             tree ct;
8171             ffestorag st = ffesymbol_storage (s);
8172             tree type;
8173             int yes;
8174
8175             cs = ffesymbol_common (s);  /* The COMMON area itself.  */
8176             if (st != NULL)     /* Else not laid out. */
8177               {
8178                 ffecom_transform_common_ (cs);
8179                 st = ffesymbol_storage (s);
8180               }
8181
8182             yes = suspend_momentary ();
8183
8184             type = ffecom_type_localvar_ (s, bt, kt);
8185
8186             cg = ffesymbol_global (cs); /* The global COMMON info.  */
8187             if ((cg == NULL)
8188                 || (ffeglobal_type (cg) != FFEGLOBAL_typeCOMMON))
8189               ct = NULL_TREE;
8190             else
8191               ct = ffeglobal_hook (cg); /* The common area's tree.  */
8192
8193             if ((ct == NULL_TREE)
8194                 || (st == NULL)
8195                 || (type == error_mark_node))
8196               t = error_mark_node;
8197             else
8198               {
8199                 ffetargetOffset offset;
8200                 ffestorag cst;
8201
8202                 cst = ffestorag_parent (st);
8203                 assert (cst == ffesymbol_storage (cs));
8204
8205                 offset = ffestorag_modulo (cst)
8206                   + ffestorag_offset (st)
8207                   - ffestorag_offset (cst);
8208
8209                 ffecom_debug_kludge_ (ct, "COMMON", s, type, offset);
8210
8211                 /* (t_type *) (((char *) &ct) + offset) */
8212
8213                 t = convert (string_type_node,  /* (char *) */
8214                              ffecom_1 (ADDR_EXPR,
8215                                        build_pointer_type (TREE_TYPE (ct)),
8216                                        ct));
8217                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
8218                               t,
8219                               build_int_2 (offset, 0));
8220                 t = convert (build_pointer_type (type),
8221                              t);
8222                 TREE_CONSTANT (t) = 1;
8223
8224                 addr = TRUE;
8225               }
8226
8227             resume_momentary (yes);
8228           }
8229           break;
8230
8231         case FFEINFO_whereIMMEDIATE:
8232         case FFEINFO_whereGLOBAL:
8233         case FFEINFO_whereFLEETING:
8234         case FFEINFO_whereFLEETING_CADDR:
8235         case FFEINFO_whereFLEETING_IADDR:
8236         case FFEINFO_whereINTRINSIC:
8237         case FFEINFO_whereCONSTANT_SUBOBJECT:
8238         default:
8239           assert ("ENTITY where unheard of" == NULL);
8240           /* Fall through. */
8241         case FFEINFO_whereANY:
8242           t = error_mark_node;
8243           break;
8244         }
8245       break;
8246
8247     case FFEINFO_kindFUNCTION:
8248       switch (ffeinfo_where (ffesymbol_info (s)))
8249         {
8250         case FFEINFO_whereLOCAL:        /* Me. */
8251           assert (!ffecom_transform_only_dummies_);
8252           t = current_function_decl;
8253           break;
8254
8255         case FFEINFO_whereGLOBAL:
8256           assert (!ffecom_transform_only_dummies_);
8257
8258           if (((g = ffesymbol_global (s)) != NULL)
8259               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8260                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8261               && (ffeglobal_hook (g) != NULL_TREE)
8262               && ffe_is_globals ())
8263             {
8264               t = ffeglobal_hook (g);
8265               break;
8266             }
8267
8268           if (ffesymbol_is_f2c (s)
8269               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8270             t = ffecom_tree_fun_type[bt][kt];
8271           else
8272             t = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
8273
8274           t = build_decl (FUNCTION_DECL,
8275                           ffecom_get_external_identifier_ (s),
8276                           t);
8277           DECL_EXTERNAL (t) = 1;
8278           TREE_PUBLIC (t) = 1;
8279
8280           t = start_decl (t, FALSE);
8281           finish_decl (t, NULL_TREE, FALSE);
8282
8283           if ((g != NULL)
8284               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8285                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8286             ffeglobal_set_hook (g, t);
8287
8288           ffecom_save_tree_forever (t);
8289
8290           break;
8291
8292         case FFEINFO_whereDUMMY:
8293           assert (ffecom_transform_only_dummies_);
8294
8295           if (ffesymbol_is_f2c (s)
8296               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8297             t = ffecom_tree_ptr_to_fun_type[bt][kt];
8298           else
8299             t = build_pointer_type
8300               (build_function_type (ffecom_tree_type[bt][kt], NULL_TREE));
8301
8302           t = build_decl (PARM_DECL,
8303                           ffecom_get_identifier_ (ffesymbol_text (s)),
8304                           t);
8305 #if BUILT_FOR_270
8306           DECL_ARTIFICIAL (t) = 1;
8307 #endif
8308           addr = TRUE;
8309           break;
8310
8311         case FFEINFO_whereCONSTANT:     /* Statement function. */
8312           assert (!ffecom_transform_only_dummies_);
8313           t = ffecom_gen_sfuncdef_ (s, bt, kt);
8314           break;
8315
8316         case FFEINFO_whereINTRINSIC:
8317           assert (!ffecom_transform_only_dummies_);
8318           break;                /* Let actual references generate their
8319                                    decls. */
8320
8321         default:
8322           assert ("FUNCTION where unheard of" == NULL);
8323           /* Fall through. */
8324         case FFEINFO_whereANY:
8325           t = error_mark_node;
8326           break;
8327         }
8328       break;
8329
8330     case FFEINFO_kindSUBROUTINE:
8331       switch (ffeinfo_where (ffesymbol_info (s)))
8332         {
8333         case FFEINFO_whereLOCAL:        /* Me. */
8334           assert (!ffecom_transform_only_dummies_);
8335           t = current_function_decl;
8336           break;
8337
8338         case FFEINFO_whereGLOBAL:
8339           assert (!ffecom_transform_only_dummies_);
8340
8341           if (((g = ffesymbol_global (s)) != NULL)
8342               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8343                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8344               && (ffeglobal_hook (g) != NULL_TREE)
8345               && ffe_is_globals ())
8346             {
8347               t = ffeglobal_hook (g);
8348               break;
8349             }
8350
8351           t = build_decl (FUNCTION_DECL,
8352                           ffecom_get_external_identifier_ (s),
8353                           ffecom_tree_subr_type);
8354           DECL_EXTERNAL (t) = 1;
8355           TREE_PUBLIC (t) = 1;
8356
8357           t = start_decl (t, FALSE);
8358           finish_decl (t, NULL_TREE, FALSE);
8359
8360           if ((g != NULL)
8361               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8362                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8363             ffeglobal_set_hook (g, t);
8364
8365           ffecom_save_tree_forever (t);
8366
8367           break;
8368
8369         case FFEINFO_whereDUMMY:
8370           assert (ffecom_transform_only_dummies_);
8371
8372           t = build_decl (PARM_DECL,
8373                           ffecom_get_identifier_ (ffesymbol_text (s)),
8374                           ffecom_tree_ptr_to_subr_type);
8375 #if BUILT_FOR_270
8376           DECL_ARTIFICIAL (t) = 1;
8377 #endif
8378           addr = TRUE;
8379           break;
8380
8381         case FFEINFO_whereINTRINSIC:
8382           assert (!ffecom_transform_only_dummies_);
8383           break;                /* Let actual references generate their
8384                                    decls. */
8385
8386         default:
8387           assert ("SUBROUTINE where unheard of" == NULL);
8388           /* Fall through. */
8389         case FFEINFO_whereANY:
8390           t = error_mark_node;
8391           break;
8392         }
8393       break;
8394
8395     case FFEINFO_kindPROGRAM:
8396       switch (ffeinfo_where (ffesymbol_info (s)))
8397         {
8398         case FFEINFO_whereLOCAL:        /* Me. */
8399           assert (!ffecom_transform_only_dummies_);
8400           t = current_function_decl;
8401           break;
8402
8403         case FFEINFO_whereCOMMON:
8404         case FFEINFO_whereDUMMY:
8405         case FFEINFO_whereGLOBAL:
8406         case FFEINFO_whereRESULT:
8407         case FFEINFO_whereFLEETING:
8408         case FFEINFO_whereFLEETING_CADDR:
8409         case FFEINFO_whereFLEETING_IADDR:
8410         case FFEINFO_whereIMMEDIATE:
8411         case FFEINFO_whereINTRINSIC:
8412         case FFEINFO_whereCONSTANT:
8413         case FFEINFO_whereCONSTANT_SUBOBJECT:
8414         default:
8415           assert ("PROGRAM where unheard of" == NULL);
8416           /* Fall through. */
8417         case FFEINFO_whereANY:
8418           t = error_mark_node;
8419           break;
8420         }
8421       break;
8422
8423     case FFEINFO_kindBLOCKDATA:
8424       switch (ffeinfo_where (ffesymbol_info (s)))
8425         {
8426         case FFEINFO_whereLOCAL:        /* Me. */
8427           assert (!ffecom_transform_only_dummies_);
8428           t = current_function_decl;
8429           break;
8430
8431         case FFEINFO_whereGLOBAL:
8432           assert (!ffecom_transform_only_dummies_);
8433
8434           t = build_decl (FUNCTION_DECL,
8435                           ffecom_get_external_identifier_ (s),
8436                           ffecom_tree_blockdata_type);
8437           DECL_EXTERNAL (t) = 1;
8438           TREE_PUBLIC (t) = 1;
8439
8440           t = start_decl (t, FALSE);
8441           finish_decl (t, NULL_TREE, FALSE);
8442
8443           ffecom_save_tree_forever (t);
8444
8445           break;
8446
8447         case FFEINFO_whereCOMMON:
8448         case FFEINFO_whereDUMMY:
8449         case FFEINFO_whereRESULT:
8450         case FFEINFO_whereFLEETING:
8451         case FFEINFO_whereFLEETING_CADDR:
8452         case FFEINFO_whereFLEETING_IADDR:
8453         case FFEINFO_whereIMMEDIATE:
8454         case FFEINFO_whereINTRINSIC:
8455         case FFEINFO_whereCONSTANT:
8456         case FFEINFO_whereCONSTANT_SUBOBJECT:
8457         default:
8458           assert ("BLOCKDATA where unheard of" == NULL);
8459           /* Fall through. */
8460         case FFEINFO_whereANY:
8461           t = error_mark_node;
8462           break;
8463         }
8464       break;
8465
8466     case FFEINFO_kindCOMMON:
8467       switch (ffeinfo_where (ffesymbol_info (s)))
8468         {
8469         case FFEINFO_whereLOCAL:
8470           assert (!ffecom_transform_only_dummies_);
8471           ffecom_transform_common_ (s);
8472           break;
8473
8474         case FFEINFO_whereNONE:
8475         case FFEINFO_whereCOMMON:
8476         case FFEINFO_whereDUMMY:
8477         case FFEINFO_whereGLOBAL:
8478         case FFEINFO_whereRESULT:
8479         case FFEINFO_whereFLEETING:
8480         case FFEINFO_whereFLEETING_CADDR:
8481         case FFEINFO_whereFLEETING_IADDR:
8482         case FFEINFO_whereIMMEDIATE:
8483         case FFEINFO_whereINTRINSIC:
8484         case FFEINFO_whereCONSTANT:
8485         case FFEINFO_whereCONSTANT_SUBOBJECT:
8486         default:
8487           assert ("COMMON where unheard of" == NULL);
8488           /* Fall through. */
8489         case FFEINFO_whereANY:
8490           t = error_mark_node;
8491           break;
8492         }
8493       break;
8494
8495     case FFEINFO_kindCONSTRUCT:
8496       switch (ffeinfo_where (ffesymbol_info (s)))
8497         {
8498         case FFEINFO_whereLOCAL:
8499           assert (!ffecom_transform_only_dummies_);
8500           break;
8501
8502         case FFEINFO_whereNONE:
8503         case FFEINFO_whereCOMMON:
8504         case FFEINFO_whereDUMMY:
8505         case FFEINFO_whereGLOBAL:
8506         case FFEINFO_whereRESULT:
8507         case FFEINFO_whereFLEETING:
8508         case FFEINFO_whereFLEETING_CADDR:
8509         case FFEINFO_whereFLEETING_IADDR:
8510         case FFEINFO_whereIMMEDIATE:
8511         case FFEINFO_whereINTRINSIC:
8512         case FFEINFO_whereCONSTANT:
8513         case FFEINFO_whereCONSTANT_SUBOBJECT:
8514         default:
8515           assert ("CONSTRUCT where unheard of" == NULL);
8516           /* Fall through. */
8517         case FFEINFO_whereANY:
8518           t = error_mark_node;
8519           break;
8520         }
8521       break;
8522
8523     case FFEINFO_kindNAMELIST:
8524       switch (ffeinfo_where (ffesymbol_info (s)))
8525         {
8526         case FFEINFO_whereLOCAL:
8527           assert (!ffecom_transform_only_dummies_);
8528           t = ffecom_transform_namelist_ (s);
8529           break;
8530
8531         case FFEINFO_whereNONE:
8532         case FFEINFO_whereCOMMON:
8533         case FFEINFO_whereDUMMY:
8534         case FFEINFO_whereGLOBAL:
8535         case FFEINFO_whereRESULT:
8536         case FFEINFO_whereFLEETING:
8537         case FFEINFO_whereFLEETING_CADDR:
8538         case FFEINFO_whereFLEETING_IADDR:
8539         case FFEINFO_whereIMMEDIATE:
8540         case FFEINFO_whereINTRINSIC:
8541         case FFEINFO_whereCONSTANT:
8542         case FFEINFO_whereCONSTANT_SUBOBJECT:
8543         default:
8544           assert ("NAMELIST where unheard of" == NULL);
8545           /* Fall through. */
8546         case FFEINFO_whereANY:
8547           t = error_mark_node;
8548           break;
8549         }
8550       break;
8551
8552     default:
8553       assert ("kind unheard of" == NULL);
8554       /* Fall through. */
8555     case FFEINFO_kindANY:
8556       t = error_mark_node;
8557       break;
8558     }
8559
8560   ffesymbol_hook (s).decl_tree = t;
8561   ffesymbol_hook (s).length_tree = tlen;
8562   ffesymbol_hook (s).addr = addr;
8563
8564   lineno = old_lineno;
8565   input_filename = old_input_filename;
8566
8567   return s;
8568 }
8569
8570 #endif
8571 /* Transform into ASSIGNable symbol.
8572
8573    Symbol has already been transformed, but for whatever reason, the
8574    resulting decl_tree has been deemed not usable for an ASSIGN target.
8575    (E.g. it isn't wide enough to hold a pointer.)  So, here we invent
8576    another local symbol of type void * and stuff that in the assign_tree
8577    argument.  The F77/F90 standards allow this implementation.  */
8578
8579 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8580 static ffesymbol
8581 ffecom_sym_transform_assign_ (ffesymbol s)
8582 {
8583   tree t;                       /* Transformed thingy. */
8584   int yes;
8585   int old_lineno = lineno;
8586   char *old_input_filename = input_filename;
8587
8588   if (ffesymbol_sfdummyparent (s) == NULL)
8589     {
8590       input_filename = ffesymbol_where_filename (s);
8591       lineno = ffesymbol_where_filelinenum (s);
8592     }
8593   else
8594     {
8595       ffesymbol sf = ffesymbol_sfdummyparent (s);
8596
8597       input_filename = ffesymbol_where_filename (sf);
8598       lineno = ffesymbol_where_filelinenum (sf);
8599     }
8600
8601   assert (!ffecom_transform_only_dummies_);
8602
8603   yes = suspend_momentary ();
8604
8605   t = build_decl (VAR_DECL,
8606                   ffecom_get_invented_identifier ("__g77_ASSIGN_%s",
8607                                                    ffesymbol_text (s)),
8608                   TREE_TYPE (null_pointer_node));
8609
8610   switch (ffesymbol_where (s))
8611     {
8612     case FFEINFO_whereLOCAL:
8613       /* Unlike for regular vars, SAVE status is easy to determine for
8614          ASSIGNed vars, since there's no initialization, there's no
8615          effective storage association (so "SAVE J" does not apply to
8616          K even given "EQUIVALENCE (J,K)"), there's no size issue
8617          to worry about, etc.  */
8618       if ((ffesymbol_is_save (s) || ffe_is_saveall ())
8619           && (ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8620           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA))
8621         TREE_STATIC (t) = 1;    /* SAVEd in proc, make static. */
8622       else
8623         TREE_STATIC (t) = 0;    /* No need to make static. */
8624       break;
8625
8626     case FFEINFO_whereCOMMON:
8627       TREE_STATIC (t) = 1;      /* Assume COMMONs always SAVEd. */
8628       break;
8629
8630     case FFEINFO_whereDUMMY:
8631       /* Note that twinning a DUMMY means the caller won't see
8632          the ASSIGNed value.  But both F77 and F90 allow implementations
8633          to do this, i.e. disallow Fortran code that would try and
8634          take advantage of actually putting a label into a variable
8635          via a dummy argument (or any other storage association, for
8636          that matter).  */
8637       TREE_STATIC (t) = 0;
8638       break;
8639
8640     default:
8641       TREE_STATIC (t) = 0;
8642       break;
8643     }
8644
8645   t = start_decl (t, FALSE);
8646   finish_decl (t, NULL_TREE, FALSE);
8647
8648   resume_momentary (yes);
8649
8650   ffesymbol_hook (s).assign_tree = t;
8651
8652   lineno = old_lineno;
8653   input_filename = old_input_filename;
8654
8655   return s;
8656 }
8657
8658 #endif
8659 /* Implement COMMON area in back end.
8660
8661    Because COMMON-based variables can be referenced in the dimension
8662    expressions of dummy (adjustable) arrays, and because dummies
8663    (in the gcc back end) need to be put in the outer binding level
8664    of a function (which has two binding levels, the outer holding
8665    the dummies and the inner holding the other vars), special care
8666    must be taken to handle COMMON areas.
8667
8668    The current strategy is basically to always tell the back end about
8669    the COMMON area as a top-level external reference to just a block
8670    of storage of the master type of that area (e.g. integer, real,
8671    character, whatever -- not a structure).  As a distinct action,
8672    if initial values are provided, tell the back end about the area
8673    as a top-level non-external (initialized) area and remember not to
8674    allow further initialization or expansion of the area.  Meanwhile,
8675    if no initialization happens at all, tell the back end about
8676    the largest size we've seen declared so the space does get reserved.
8677    (This function doesn't handle all that stuff, but it does some
8678    of the important things.)
8679
8680    Meanwhile, for COMMON variables themselves, just keep creating
8681    references like *((float *) (&common_area + offset)) each time
8682    we reference the variable.  In other words, don't make a VAR_DECL
8683    or any kind of component reference (like we used to do before 0.4),
8684    though we might do that as well just for debugging purposes (and
8685    stuff the rtl with the appropriate offset expression).  */
8686
8687 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8688 static void
8689 ffecom_transform_common_ (ffesymbol s)
8690 {
8691   ffestorag st = ffesymbol_storage (s);
8692   ffeglobal g = ffesymbol_global (s);
8693   tree cbt;
8694   tree cbtype;
8695   tree init;
8696   tree high;
8697   bool is_init = ffestorag_is_init (st);
8698
8699   assert (st != NULL);
8700
8701   if ((g == NULL)
8702       || (ffeglobal_type (g) != FFEGLOBAL_typeCOMMON))
8703     return;
8704
8705   /* First update the size of the area in global terms.  */
8706
8707   ffeglobal_size_common (s, ffestorag_size (st));
8708
8709   if (!ffeglobal_common_init (g))
8710     is_init = FALSE;    /* No explicit init, don't let erroneous joins init. */
8711
8712   cbt = ffeglobal_hook (g);
8713
8714   /* If we already have declared this common block for a previous program
8715      unit, and either we already initialized it or we don't have new
8716      initialization for it, just return what we have without changing it.  */
8717
8718   if ((cbt != NULL_TREE)
8719       && (!is_init
8720           || !DECL_EXTERNAL (cbt)))
8721     {
8722       if (st->hook == NULL) ffestorag_set_hook (st, cbt);
8723       return;
8724     }
8725
8726   /* Process inits.  */
8727
8728   if (is_init)
8729     {
8730       if (ffestorag_init (st) != NULL)
8731         {
8732           ffebld sexp;
8733
8734           /* Set the padding for the expression, so ffecom_expr
8735              knows to insert that many zeros.  */
8736           switch (ffebld_op (sexp = ffestorag_init (st)))
8737             {
8738             case FFEBLD_opCONTER:
8739               ffebld_conter_set_pad (sexp, ffestorag_modulo (st));
8740               break;
8741
8742             case FFEBLD_opARRTER:
8743               ffebld_arrter_set_pad (sexp, ffestorag_modulo (st));
8744               break;
8745
8746             case FFEBLD_opACCTER:
8747               ffebld_accter_set_pad (sexp, ffestorag_modulo (st));
8748               break;
8749
8750             default:
8751               assert ("bad op for cmn init (pad)" == NULL);
8752               break;
8753             }
8754
8755           init = ffecom_expr (sexp);
8756           if (init == error_mark_node)
8757             {                   /* Hopefully the back end complained! */
8758               init = NULL_TREE;
8759               if (cbt != NULL_TREE)
8760                 return;
8761             }
8762         }
8763       else
8764         init = error_mark_node;
8765     }
8766   else
8767     init = NULL_TREE;
8768
8769   /* cbtype must be permanently allocated!  */
8770
8771   /* Allocate the MAX of the areas so far, seen filewide.  */
8772   high = build_int_2 ((ffeglobal_common_size (g)
8773                        + ffeglobal_common_pad (g)) - 1, 0);
8774   TREE_TYPE (high) = ffecom_integer_type_node;
8775
8776   if (init)
8777     cbtype = build_array_type (char_type_node,
8778                                build_range_type (integer_type_node,
8779                                                  integer_zero_node,
8780                                                  high));
8781   else
8782     cbtype = build_array_type (char_type_node, NULL_TREE);
8783
8784   if (cbt == NULL_TREE)
8785     {
8786       cbt
8787         = build_decl (VAR_DECL,
8788                       ffecom_get_external_identifier_ (s),
8789                       cbtype);
8790       TREE_STATIC (cbt) = 1;
8791       TREE_PUBLIC (cbt) = 1;
8792     }
8793   else
8794     {
8795       assert (is_init);
8796       TREE_TYPE (cbt) = cbtype;
8797     }
8798   DECL_EXTERNAL (cbt) = init ? 0 : 1;
8799   DECL_INITIAL (cbt) = init ? error_mark_node : NULL_TREE;
8800
8801   cbt = start_decl (cbt, TRUE);
8802   if (ffeglobal_hook (g) != NULL)
8803     assert (cbt == ffeglobal_hook (g));
8804
8805   assert (!init || !DECL_EXTERNAL (cbt));
8806
8807   /* Make sure that any type can live in COMMON and be referenced
8808      without getting a bus error.  We could pick the most restrictive
8809      alignment of all entities actually placed in the COMMON, but
8810      this seems easy enough.  */
8811
8812   DECL_ALIGN (cbt) = BIGGEST_ALIGNMENT;
8813
8814   if (is_init && (ffestorag_init (st) == NULL))
8815     init = ffecom_init_zero_ (cbt);
8816
8817   finish_decl (cbt, init, TRUE);
8818
8819   if (is_init)
8820     ffestorag_set_init (st, ffebld_new_any ());
8821
8822   if (init)
8823     {
8824       assert (DECL_SIZE_UNIT (cbt) != NULL_TREE);
8825       assert (TREE_CODE (DECL_SIZE_UNIT (cbt)) == INTEGER_CST);
8826       assert (TREE_INT_CST_HIGH (DECL_SIZE_UNIT (cbt)) == 0);
8827       assert (TREE_INT_CST_LOW (DECL_SIZE_UNIT (cbt))
8828               == ffeglobal_common_size (g) + ffeglobal_common_pad (g));
8829     }
8830
8831   ffeglobal_set_hook (g, cbt);
8832
8833   ffestorag_set_hook (st, cbt);
8834
8835   ffecom_save_tree_forever (cbt);
8836 }
8837
8838 #endif
8839 /* Make master area for local EQUIVALENCE.  */
8840
8841 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8842 static void
8843 ffecom_transform_equiv_ (ffestorag eqst)
8844 {
8845   tree eqt;
8846   tree eqtype;
8847   tree init;
8848   tree high;
8849   bool is_init = ffestorag_is_init (eqst);
8850   int yes;
8851
8852   assert (eqst != NULL);
8853
8854   eqt = ffestorag_hook (eqst);
8855
8856   if (eqt != NULL_TREE)
8857     return;
8858
8859   /* Process inits.  */
8860
8861   if (is_init)
8862     {
8863       if (ffestorag_init (eqst) != NULL)
8864         {
8865           ffebld sexp;
8866
8867           /* Set the padding for the expression, so ffecom_expr
8868              knows to insert that many zeros.  */
8869           switch (ffebld_op (sexp = ffestorag_init (eqst)))
8870             {
8871             case FFEBLD_opCONTER:
8872               ffebld_conter_set_pad (sexp, ffestorag_modulo (eqst));
8873               break;
8874
8875             case FFEBLD_opARRTER:
8876               ffebld_arrter_set_pad (sexp, ffestorag_modulo (eqst));
8877               break;
8878
8879             case FFEBLD_opACCTER:
8880               ffebld_accter_set_pad (sexp, ffestorag_modulo (eqst));
8881               break;
8882
8883             default:
8884               assert ("bad op for eqv init (pad)" == NULL);
8885               break;
8886             }
8887
8888           init = ffecom_expr (sexp);
8889           if (init == error_mark_node)
8890             init = NULL_TREE;   /* Hopefully the back end complained! */
8891         }
8892       else
8893         init = error_mark_node;
8894     }
8895   else if (ffe_is_init_local_zero ())
8896     init = error_mark_node;
8897   else
8898     init = NULL_TREE;
8899
8900   ffecom_member_namelisted_ = FALSE;
8901   ffestorag_drive (ffestorag_list_equivs (eqst),
8902                    &ffecom_member_phase1_,
8903                    eqst);
8904
8905   yes = suspend_momentary ();
8906
8907   high = build_int_2 ((ffestorag_size (eqst)
8908                        + ffestorag_modulo (eqst)) - 1, 0);
8909   TREE_TYPE (high) = ffecom_integer_type_node;
8910
8911   eqtype = build_array_type (char_type_node,
8912                              build_range_type (ffecom_integer_type_node,
8913                                                ffecom_integer_zero_node,
8914                                                high));
8915
8916   eqt = build_decl (VAR_DECL,
8917                     ffecom_get_invented_identifier ("__g77_equiv_%s",
8918                                                     ffesymbol_text
8919                                                     (ffestorag_symbol (eqst))),
8920                     eqtype);
8921   DECL_EXTERNAL (eqt) = 0;
8922   if (is_init
8923       || ffecom_member_namelisted_
8924 #ifdef FFECOM_sizeMAXSTACKITEM
8925       || (ffestorag_size (eqst) > FFECOM_sizeMAXSTACKITEM)
8926 #endif
8927       || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8928           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
8929           && (ffestorag_is_save (eqst) || ffe_is_saveall ())))
8930     TREE_STATIC (eqt) = 1;
8931   else
8932     TREE_STATIC (eqt) = 0;
8933   TREE_PUBLIC (eqt) = 0;
8934   DECL_CONTEXT (eqt) = current_function_decl;
8935   if (init)
8936     DECL_INITIAL (eqt) = error_mark_node;
8937   else
8938     DECL_INITIAL (eqt) = NULL_TREE;
8939
8940   eqt = start_decl (eqt, FALSE);
8941
8942   /* Make sure that any type can live in EQUIVALENCE and be referenced
8943      without getting a bus error.  We could pick the most restrictive
8944      alignment of all entities actually placed in the EQUIVALENCE, but
8945      this seems easy enough.  */
8946
8947   DECL_ALIGN (eqt) = BIGGEST_ALIGNMENT;
8948
8949   if ((!is_init && ffe_is_init_local_zero ())
8950       || (is_init && (ffestorag_init (eqst) == NULL)))
8951     init = ffecom_init_zero_ (eqt);
8952
8953   finish_decl (eqt, init, FALSE);
8954
8955   if (is_init)
8956     ffestorag_set_init (eqst, ffebld_new_any ());
8957
8958   {
8959     assert (TREE_CODE (DECL_SIZE_UNIT (eqt)) == INTEGER_CST);
8960     assert (TREE_INT_CST_HIGH (DECL_SIZE_UNIT (eqt)) == 0);
8961     assert (TREE_INT_CST_LOW (DECL_SIZE_UNIT (eqt))
8962             == ffestorag_size (eqst) + ffestorag_modulo (eqst));
8963   }
8964
8965   ffestorag_set_hook (eqst, eqt);
8966
8967 #ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
8968   ffestorag_drive (ffestorag_list_equivs (eqst),
8969                    &ffecom_member_phase2_,
8970                    eqst);
8971 #endif
8972
8973   resume_momentary (yes);
8974 }
8975
8976 #endif
8977 /* Implement NAMELIST in back end.  See f2c/format.c for more info.  */
8978
8979 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8980 static tree
8981 ffecom_transform_namelist_ (ffesymbol s)
8982 {
8983   tree nmlt;
8984   tree nmltype = ffecom_type_namelist_ ();
8985   tree nmlinits;
8986   tree nameinit;
8987   tree varsinit;
8988   tree nvarsinit;
8989   tree field;
8990   tree high;
8991   int yes;
8992   int i;
8993   static int mynumber = 0;
8994
8995   yes = suspend_momentary ();
8996
8997   nmlt = build_decl (VAR_DECL,
8998                      ffecom_get_invented_identifier ("__g77_namelist_%d",
8999                                                      mynumber++),
9000                      nmltype);
9001   TREE_STATIC (nmlt) = 1;
9002   DECL_INITIAL (nmlt) = error_mark_node;
9003
9004   nmlt = start_decl (nmlt, FALSE);
9005
9006   /* Process inits.  */
9007
9008   i = strlen (ffesymbol_text (s));
9009
9010   high = build_int_2 (i, 0);
9011   TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
9012
9013   nameinit = ffecom_build_f2c_string_ (i + 1,
9014                                        ffesymbol_text (s));
9015   TREE_TYPE (nameinit)
9016     = build_type_variant
9017     (build_array_type
9018      (char_type_node,
9019       build_range_type (ffecom_f2c_ftnlen_type_node,
9020                         ffecom_f2c_ftnlen_one_node,
9021                         high)),
9022      1, 0);
9023   TREE_CONSTANT (nameinit) = 1;
9024   TREE_STATIC (nameinit) = 1;
9025   nameinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (nameinit)),
9026                        nameinit);
9027
9028   varsinit = ffecom_vardesc_array_ (s);
9029   varsinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (varsinit)),
9030                        varsinit);
9031   TREE_CONSTANT (varsinit) = 1;
9032   TREE_STATIC (varsinit) = 1;
9033
9034   {
9035     ffebld b;
9036
9037     for (i = 0, b = ffesymbol_namelist (s); b != NULL; b = ffebld_trail (b))
9038       ++i;
9039   }
9040   nvarsinit = build_int_2 (i, 0);
9041   TREE_TYPE (nvarsinit) = integer_type_node;
9042   TREE_CONSTANT (nvarsinit) = 1;
9043   TREE_STATIC (nvarsinit) = 1;
9044
9045   nmlinits = build_tree_list ((field = TYPE_FIELDS (nmltype)), nameinit);
9046   TREE_CHAIN (nmlinits) = build_tree_list ((field = TREE_CHAIN (field)),
9047                                            varsinit);
9048   TREE_CHAIN (TREE_CHAIN (nmlinits))
9049     = build_tree_list ((field = TREE_CHAIN (field)), nvarsinit);
9050
9051   nmlinits = build (CONSTRUCTOR, nmltype, NULL_TREE, nmlinits);
9052   TREE_CONSTANT (nmlinits) = 1;
9053   TREE_STATIC (nmlinits) = 1;
9054
9055   finish_decl (nmlt, nmlinits, FALSE);
9056
9057   nmlt = ffecom_1 (ADDR_EXPR, build_pointer_type (nmltype), nmlt);
9058
9059   resume_momentary (yes);
9060
9061   return nmlt;
9062 }
9063
9064 #endif
9065
9066 /* A subroutine of ffecom_tree_canonize_ref_.  The incoming tree is
9067    analyzed on the assumption it is calculating a pointer to be
9068    indirected through.  It must return the proper decl and offset,
9069    taking into account different units of measurements for offsets.  */
9070
9071 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9072 static void
9073 ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
9074                            tree t)
9075 {
9076   switch (TREE_CODE (t))
9077     {
9078     case NOP_EXPR:
9079     case CONVERT_EXPR:
9080     case NON_LVALUE_EXPR:
9081       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
9082       break;
9083
9084     case PLUS_EXPR:
9085       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
9086       if ((*decl == NULL_TREE)
9087           || (*decl == error_mark_node))
9088         break;
9089
9090       if (TREE_CODE (TREE_OPERAND (t, 1)) == INTEGER_CST)
9091         {
9092           /* An offset into COMMON.  */
9093           *offset = fold (build (PLUS_EXPR, TREE_TYPE (*offset),
9094                                  *offset, TREE_OPERAND (t, 1)));
9095           /* Convert offset (presumably in bytes) into canonical units
9096              (presumably bits).  */
9097           *offset = fold (build (MULT_EXPR, TREE_TYPE (*offset),
9098                                  TYPE_SIZE (TREE_TYPE (TREE_TYPE (t))),
9099                                  *offset));
9100           break;
9101         }
9102       /* Not a COMMON reference, so an unrecognized pattern.  */
9103       *decl = error_mark_node;
9104       break;
9105
9106     case PARM_DECL:
9107       *decl = t;
9108       *offset = bitsize_int (0);
9109       break;
9110
9111     case ADDR_EXPR:
9112       if (TREE_CODE (TREE_OPERAND (t, 0)) == VAR_DECL)
9113         {
9114           /* A reference to COMMON.  */
9115           *decl = TREE_OPERAND (t, 0);
9116           *offset = bitsize_int (0);
9117           break;
9118         }
9119       /* Fall through.  */
9120     default:
9121       /* Not a COMMON reference, so an unrecognized pattern.  */
9122       *decl = error_mark_node;
9123       break;
9124     }
9125 }
9126 #endif
9127
9128 /* Given a tree that is possibly intended for use as an lvalue, return
9129    information representing a canonical view of that tree as a decl, an
9130    offset into that decl, and a size for the lvalue.
9131
9132    If there's no applicable decl, NULL_TREE is returned for the decl,
9133    and the other fields are left undefined.
9134
9135    If the tree doesn't fit the recognizable forms, an ERROR_MARK node
9136    is returned for the decl, and the other fields are left undefined.
9137
9138    Otherwise, the decl returned currently is either a VAR_DECL or a
9139    PARM_DECL.
9140
9141    The offset returned is always valid, but of course not necessarily
9142    a constant, and not necessarily converted into the appropriate
9143    type, leaving that up to the caller (so as to avoid that overhead
9144    if the decls being looked at are different anyway).
9145
9146    If the size cannot be determined (e.g. an adjustable array),
9147    an ERROR_MARK node is returned for the size.  Otherwise, the
9148    size returned is valid, not necessarily a constant, and not
9149    necessarily converted into the appropriate type as with the
9150    offset.
9151
9152    Note that the offset and size expressions are expressed in the
9153    base storage units (usually bits) rather than in the units of
9154    the type of the decl, because two decls with different types
9155    might overlap but with apparently non-overlapping array offsets,
9156    whereas converting the array offsets to consistant offsets will
9157    reveal the overlap.  */
9158
9159 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9160 static void
9161 ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
9162                            tree *size, tree t)
9163 {
9164   /* The default path is to report a nonexistant decl.  */
9165   *decl = NULL_TREE;
9166
9167   if (t == NULL_TREE)
9168     return;
9169
9170   switch (TREE_CODE (t))
9171     {
9172     case ERROR_MARK:
9173     case IDENTIFIER_NODE:
9174     case INTEGER_CST:
9175     case REAL_CST:
9176     case COMPLEX_CST:
9177     case STRING_CST:
9178     case CONST_DECL:
9179     case PLUS_EXPR:
9180     case MINUS_EXPR:
9181     case MULT_EXPR:
9182     case TRUNC_DIV_EXPR:
9183     case CEIL_DIV_EXPR:
9184     case FLOOR_DIV_EXPR:
9185     case ROUND_DIV_EXPR:
9186     case TRUNC_MOD_EXPR:
9187     case CEIL_MOD_EXPR:
9188     case FLOOR_MOD_EXPR:
9189     case ROUND_MOD_EXPR:
9190     case RDIV_EXPR:
9191     case EXACT_DIV_EXPR:
9192     case FIX_TRUNC_EXPR:
9193     case FIX_CEIL_EXPR:
9194     case FIX_FLOOR_EXPR:
9195     case FIX_ROUND_EXPR:
9196     case FLOAT_EXPR:
9197     case EXPON_EXPR:
9198     case NEGATE_EXPR:
9199     case MIN_EXPR:
9200     case MAX_EXPR:
9201     case ABS_EXPR:
9202     case FFS_EXPR:
9203     case LSHIFT_EXPR:
9204     case RSHIFT_EXPR:
9205     case LROTATE_EXPR:
9206     case RROTATE_EXPR:
9207     case BIT_IOR_EXPR:
9208     case BIT_XOR_EXPR:
9209     case BIT_AND_EXPR:
9210     case BIT_ANDTC_EXPR:
9211     case BIT_NOT_EXPR:
9212     case TRUTH_ANDIF_EXPR:
9213     case TRUTH_ORIF_EXPR:
9214     case TRUTH_AND_EXPR:
9215     case TRUTH_OR_EXPR:
9216     case TRUTH_XOR_EXPR:
9217     case TRUTH_NOT_EXPR:
9218     case LT_EXPR:
9219     case LE_EXPR:
9220     case GT_EXPR:
9221     case GE_EXPR:
9222     case EQ_EXPR:
9223     case NE_EXPR:
9224     case COMPLEX_EXPR:
9225     case CONJ_EXPR:
9226     case REALPART_EXPR:
9227     case IMAGPART_EXPR:
9228     case LABEL_EXPR:
9229     case COMPONENT_REF:
9230     case COMPOUND_EXPR:
9231     case ADDR_EXPR:
9232       return;
9233
9234     case VAR_DECL:
9235     case PARM_DECL:
9236       *decl = t;
9237       *offset = bitsize_int (0);
9238       *size = TYPE_SIZE (TREE_TYPE (t));
9239       return;
9240
9241     case ARRAY_REF:
9242       {
9243         tree array = TREE_OPERAND (t, 0);
9244         tree element = TREE_OPERAND (t, 1);
9245         tree init_offset;
9246
9247         if ((array == NULL_TREE)
9248             || (element == NULL_TREE))
9249           {
9250             *decl = error_mark_node;
9251             return;
9252           }
9253
9254         ffecom_tree_canonize_ref_ (decl, &init_offset, size,
9255                                    array);
9256         if ((*decl == NULL_TREE)
9257             || (*decl == error_mark_node))
9258           return;
9259
9260         *offset
9261           = size_binop (MULT_EXPR,
9262                         TYPE_SIZE (TREE_TYPE (TREE_TYPE (array))),
9263                         convert (sizetype,
9264                                  fold (build (MINUS_EXPR, TREE_TYPE (element),
9265                                               element,
9266                                               TYPE_MIN_VALUE
9267                                               (TYPE_DOMAIN
9268                                                (TREE_TYPE (array)))))));;
9269
9270         *offset = size_binop (PLUS_EXPR, convert (sizetype, init_offset),
9271                               *offset);
9272
9273         *size = TYPE_SIZE (TREE_TYPE (t));
9274         return;
9275       }
9276
9277     case INDIRECT_REF:
9278
9279       /* Most of this code is to handle references to COMMON.  And so
9280          far that is useful only for calling library functions, since
9281          external (user) functions might reference common areas.  But
9282          even calling an external function, it's worthwhile to decode
9283          COMMON references because if not storing into COMMON, we don't
9284          want COMMON-based arguments to gratuitously force use of a
9285          temporary.  */
9286
9287       *size = TYPE_SIZE (TREE_TYPE (t));
9288
9289       ffecom_tree_canonize_ptr_ (decl, offset,
9290                                  TREE_OPERAND (t, 0));
9291
9292       return;
9293
9294     case CONVERT_EXPR:
9295     case NOP_EXPR:
9296     case MODIFY_EXPR:
9297     case NON_LVALUE_EXPR:
9298     case RESULT_DECL:
9299     case FIELD_DECL:
9300     case COND_EXPR:             /* More cases than we can handle. */
9301     case SAVE_EXPR:
9302     case REFERENCE_EXPR:
9303     case PREDECREMENT_EXPR:
9304     case PREINCREMENT_EXPR:
9305     case POSTDECREMENT_EXPR:
9306     case POSTINCREMENT_EXPR:
9307     case CALL_EXPR:
9308     default:
9309       *decl = error_mark_node;
9310       return;
9311     }
9312 }
9313 #endif
9314
9315 /* Do divide operation appropriate to type of operands.  */
9316
9317 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9318 static tree
9319 ffecom_tree_divide_ (tree tree_type, tree left, tree right,
9320                      tree dest_tree, ffebld dest, bool *dest_used,
9321                      tree hook)
9322 {
9323   if ((left == error_mark_node)
9324       || (right == error_mark_node))
9325     return error_mark_node;
9326
9327   switch (TREE_CODE (tree_type))
9328     {
9329     case INTEGER_TYPE:
9330       return ffecom_2 (TRUNC_DIV_EXPR, tree_type,
9331                        left,
9332                        right);
9333
9334     case COMPLEX_TYPE:
9335       if (! optimize_size)
9336         return ffecom_2 (RDIV_EXPR, tree_type,
9337                          left,
9338                          right);
9339       {
9340         ffecomGfrt ix;
9341
9342         if (TREE_TYPE (tree_type)
9343             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9344           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9345         else
9346           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9347
9348         left = ffecom_1 (ADDR_EXPR,
9349                          build_pointer_type (TREE_TYPE (left)),
9350                          left);
9351         left = build_tree_list (NULL_TREE, left);
9352         right = ffecom_1 (ADDR_EXPR,
9353                           build_pointer_type (TREE_TYPE (right)),
9354                           right);
9355         right = build_tree_list (NULL_TREE, right);
9356         TREE_CHAIN (left) = right;
9357
9358         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9359                              ffecom_gfrt_kindtype (ix),
9360                              ffe_is_f2c_library (),
9361                              tree_type,
9362                              left,
9363                              dest_tree, dest, dest_used,
9364                              NULL_TREE, TRUE, hook);
9365       }
9366       break;
9367
9368     case RECORD_TYPE:
9369       {
9370         ffecomGfrt ix;
9371
9372         if (TREE_TYPE (TYPE_FIELDS (tree_type))
9373             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9374           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9375         else
9376           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9377
9378         left = ffecom_1 (ADDR_EXPR,
9379                          build_pointer_type (TREE_TYPE (left)),
9380                          left);
9381         left = build_tree_list (NULL_TREE, left);
9382         right = ffecom_1 (ADDR_EXPR,
9383                           build_pointer_type (TREE_TYPE (right)),
9384                           right);
9385         right = build_tree_list (NULL_TREE, right);
9386         TREE_CHAIN (left) = right;
9387
9388         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9389                              ffecom_gfrt_kindtype (ix),
9390                              ffe_is_f2c_library (),
9391                              tree_type,
9392                              left,
9393                              dest_tree, dest, dest_used,
9394                              NULL_TREE, TRUE, hook);
9395       }
9396       break;
9397
9398     default:
9399       return ffecom_2 (RDIV_EXPR, tree_type,
9400                        left,
9401                        right);
9402     }
9403 }
9404
9405 #endif
9406 /* Build type info for non-dummy variable.  */
9407
9408 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9409 static tree
9410 ffecom_type_localvar_ (ffesymbol s, ffeinfoBasictype bt,
9411                        ffeinfoKindtype kt)
9412 {
9413   tree type;
9414   ffebld dl;
9415   ffebld dim;
9416   tree lowt;
9417   tree hight;
9418
9419   type = ffecom_tree_type[bt][kt];
9420   if (bt == FFEINFO_basictypeCHARACTER)
9421     {
9422       hight = build_int_2 (ffesymbol_size (s), 0);
9423       TREE_TYPE (hight) = ffecom_f2c_ftnlen_type_node;
9424
9425       type
9426         = build_array_type
9427           (type,
9428            build_range_type (ffecom_f2c_ftnlen_type_node,
9429                              ffecom_f2c_ftnlen_one_node,
9430                              hight));
9431       type = ffecom_check_size_overflow_ (s, type, FALSE);
9432     }
9433
9434   for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
9435     {
9436       if (type == error_mark_node)
9437         break;
9438
9439       dim = ffebld_head (dl);
9440       assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
9441
9442       if (ffebld_left (dim) == NULL)
9443         lowt = integer_one_node;
9444       else
9445         lowt = ffecom_expr (ffebld_left (dim));
9446
9447       if (TREE_CODE (lowt) != INTEGER_CST)
9448         lowt = variable_size (lowt);
9449
9450       assert (ffebld_right (dim) != NULL);
9451       hight = ffecom_expr (ffebld_right (dim));
9452
9453       if (TREE_CODE (hight) != INTEGER_CST)
9454         hight = variable_size (hight);
9455
9456       type = build_array_type (type,
9457                                build_range_type (ffecom_integer_type_node,
9458                                                  lowt, hight));
9459       type = ffecom_check_size_overflow_ (s, type, FALSE);
9460     }
9461
9462   return type;
9463 }
9464
9465 #endif
9466 /* Build Namelist type.  */
9467
9468 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9469 static tree
9470 ffecom_type_namelist_ ()
9471 {
9472   static tree type = NULL_TREE;
9473
9474   if (type == NULL_TREE)
9475     {
9476       static tree namefield, varsfield, nvarsfield;
9477       tree vardesctype;
9478
9479       vardesctype = ffecom_type_vardesc_ ();
9480
9481       type = make_node (RECORD_TYPE);
9482
9483       vardesctype = build_pointer_type (build_pointer_type (vardesctype));
9484
9485       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9486                                      string_type_node);
9487       varsfield = ffecom_decl_field (type, namefield, "vars", vardesctype);
9488       nvarsfield = ffecom_decl_field (type, varsfield, "nvars",
9489                                       integer_type_node);
9490
9491       TYPE_FIELDS (type) = namefield;
9492       layout_type (type);
9493
9494       ggc_add_tree_root (&type, 1);
9495     }
9496
9497   return type;
9498 }
9499
9500 #endif
9501
9502 /* Build Vardesc type.  */
9503
9504 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9505 static tree
9506 ffecom_type_vardesc_ ()
9507 {
9508   static tree type = NULL_TREE;
9509   static tree namefield, addrfield, dimsfield, typefield;
9510
9511   if (type == NULL_TREE)
9512     {
9513       type = make_node (RECORD_TYPE);
9514
9515       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9516                                      string_type_node);
9517       addrfield = ffecom_decl_field (type, namefield, "addr",
9518                                      string_type_node);
9519       dimsfield = ffecom_decl_field (type, addrfield, "dims",
9520                                      ffecom_f2c_ptr_to_ftnlen_type_node);
9521       typefield = ffecom_decl_field (type, dimsfield, "type",
9522                                      integer_type_node);
9523
9524       TYPE_FIELDS (type) = namefield;
9525       layout_type (type);
9526
9527       ggc_add_tree_root (&type, 1);
9528     }
9529
9530   return type;
9531 }
9532
9533 #endif
9534
9535 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9536 static tree
9537 ffecom_vardesc_ (ffebld expr)
9538 {
9539   ffesymbol s;
9540
9541   assert (ffebld_op (expr) == FFEBLD_opSYMTER);
9542   s = ffebld_symter (expr);
9543
9544   if (ffesymbol_hook (s).vardesc_tree == NULL_TREE)
9545     {
9546       int i;
9547       tree vardesctype = ffecom_type_vardesc_ ();
9548       tree var;
9549       tree nameinit;
9550       tree dimsinit;
9551       tree addrinit;
9552       tree typeinit;
9553       tree field;
9554       tree varinits;
9555       int yes;
9556       static int mynumber = 0;
9557
9558       yes = suspend_momentary ();
9559
9560       var = build_decl (VAR_DECL,
9561                         ffecom_get_invented_identifier ("__g77_vardesc_%d",
9562                                                         mynumber++),
9563                         vardesctype);
9564       TREE_STATIC (var) = 1;
9565       DECL_INITIAL (var) = error_mark_node;
9566
9567       var = start_decl (var, FALSE);
9568
9569       /* Process inits.  */
9570
9571       nameinit = ffecom_build_f2c_string_ ((i = strlen (ffesymbol_text (s)))
9572                                            + 1,
9573                                            ffesymbol_text (s));
9574       TREE_TYPE (nameinit)
9575         = build_type_variant
9576         (build_array_type
9577          (char_type_node,
9578           build_range_type (integer_type_node,
9579                             integer_one_node,
9580                             build_int_2 (i, 0))),
9581          1, 0);
9582       TREE_CONSTANT (nameinit) = 1;
9583       TREE_STATIC (nameinit) = 1;
9584       nameinit = ffecom_1 (ADDR_EXPR,
9585                            build_pointer_type (TREE_TYPE (nameinit)),
9586                            nameinit);
9587
9588       addrinit = ffecom_arg_ptr_to_expr (expr, &typeinit);
9589
9590       dimsinit = ffecom_vardesc_dims_ (s);
9591
9592       if (typeinit == NULL_TREE)
9593         {
9594           ffeinfoBasictype bt = ffesymbol_basictype (s);
9595           ffeinfoKindtype kt = ffesymbol_kindtype (s);
9596           int tc = ffecom_f2c_typecode (bt, kt);
9597
9598           assert (tc != -1);
9599           typeinit = build_int_2 (tc, (tc < 0) ? -1 : 0);
9600         }
9601       else
9602         typeinit = ffecom_1 (NEGATE_EXPR, TREE_TYPE (typeinit), typeinit);
9603
9604       varinits = build_tree_list ((field = TYPE_FIELDS (vardesctype)),
9605                                   nameinit);
9606       TREE_CHAIN (varinits) = build_tree_list ((field = TREE_CHAIN (field)),
9607                                                addrinit);
9608       TREE_CHAIN (TREE_CHAIN (varinits))
9609         = build_tree_list ((field = TREE_CHAIN (field)), dimsinit);
9610       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits)))
9611         = build_tree_list ((field = TREE_CHAIN (field)), typeinit);
9612
9613       varinits = build (CONSTRUCTOR, vardesctype, NULL_TREE, varinits);
9614       TREE_CONSTANT (varinits) = 1;
9615       TREE_STATIC (varinits) = 1;
9616
9617       finish_decl (var, varinits, FALSE);
9618
9619       var = ffecom_1 (ADDR_EXPR, build_pointer_type (vardesctype), var);
9620
9621       resume_momentary (yes);
9622
9623       ffesymbol_hook (s).vardesc_tree = var;
9624     }
9625
9626   return ffesymbol_hook (s).vardesc_tree;
9627 }
9628
9629 #endif
9630 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9631 static tree
9632 ffecom_vardesc_array_ (ffesymbol s)
9633 {
9634   ffebld b;
9635   tree list;
9636   tree item = NULL_TREE;
9637   tree var;
9638   int i;
9639   int yes;
9640   static int mynumber = 0;
9641
9642   for (i = 0, list = NULL_TREE, b = ffesymbol_namelist (s);
9643        b != NULL;
9644        b = ffebld_trail (b), ++i)
9645     {
9646       tree t;
9647
9648       t = ffecom_vardesc_ (ffebld_head (b));
9649
9650       if (list == NULL_TREE)
9651         list = item = build_tree_list (NULL_TREE, t);
9652       else
9653         {
9654           TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9655           item = TREE_CHAIN (item);
9656         }
9657     }
9658
9659   yes = suspend_momentary ();
9660
9661   item = build_array_type (build_pointer_type (ffecom_type_vardesc_ ()),
9662                            build_range_type (integer_type_node,
9663                                              integer_one_node,
9664                                              build_int_2 (i, 0)));
9665   list = build (CONSTRUCTOR, item, NULL_TREE, list);
9666   TREE_CONSTANT (list) = 1;
9667   TREE_STATIC (list) = 1;
9668
9669   var = ffecom_get_invented_identifier ("__g77_vardesc_array_%d", mynumber++);
9670   var = build_decl (VAR_DECL, var, item);
9671   TREE_STATIC (var) = 1;
9672   DECL_INITIAL (var) = error_mark_node;
9673   var = start_decl (var, FALSE);
9674   finish_decl (var, list, FALSE);
9675
9676   resume_momentary (yes);
9677
9678   return var;
9679 }
9680
9681 #endif
9682 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9683 static tree
9684 ffecom_vardesc_dims_ (ffesymbol s)
9685 {
9686   if (ffesymbol_dims (s) == NULL)
9687     return convert (ffecom_f2c_ptr_to_ftnlen_type_node,
9688                     integer_zero_node);
9689
9690   {
9691     ffebld b;
9692     ffebld e;
9693     tree list;
9694     tree backlist;
9695     tree item = NULL_TREE;
9696     tree var;
9697     int yes;
9698     tree numdim;
9699     tree numelem;
9700     tree baseoff = NULL_TREE;
9701     static int mynumber = 0;
9702
9703     numdim = build_int_2 ((int) ffesymbol_rank (s), 0);
9704     TREE_TYPE (numdim) = ffecom_f2c_ftnlen_type_node;
9705
9706     numelem = ffecom_expr (ffesymbol_arraysize (s));
9707     TREE_TYPE (numelem) = ffecom_f2c_ftnlen_type_node;
9708
9709     list = NULL_TREE;
9710     backlist = NULL_TREE;
9711     for (b = ffesymbol_dims (s), e = ffesymbol_extents (s);
9712          b != NULL;
9713          b = ffebld_trail (b), e = ffebld_trail (e))
9714       {
9715         tree t;
9716         tree low;
9717         tree back;
9718
9719         if (ffebld_trail (b) == NULL)
9720           t = NULL_TREE;
9721         else
9722           {
9723             t = convert (ffecom_f2c_ftnlen_type_node,
9724                          ffecom_expr (ffebld_head (e)));
9725
9726             if (list == NULL_TREE)
9727               list = item = build_tree_list (NULL_TREE, t);
9728             else
9729               {
9730                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9731                 item = TREE_CHAIN (item);
9732               }
9733           }
9734
9735         if (ffebld_left (ffebld_head (b)) == NULL)
9736           low = ffecom_integer_one_node;
9737         else
9738           low = ffecom_expr (ffebld_left (ffebld_head (b)));
9739         low = convert (ffecom_f2c_ftnlen_type_node, low);
9740
9741         back = build_tree_list (low, t);
9742         TREE_CHAIN (back) = backlist;
9743         backlist = back;
9744       }
9745
9746     for (item = backlist; item != NULL_TREE; item = TREE_CHAIN (item))
9747       {
9748         if (TREE_VALUE (item) == NULL_TREE)
9749           baseoff = TREE_PURPOSE (item);
9750         else
9751           baseoff = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
9752                               TREE_PURPOSE (item),
9753                               ffecom_2 (MULT_EXPR,
9754                                         ffecom_f2c_ftnlen_type_node,
9755                                         TREE_VALUE (item),
9756                                         baseoff));
9757       }
9758
9759     /* backlist now dead, along with all TREE_PURPOSEs on it.  */
9760
9761     baseoff = build_tree_list (NULL_TREE, baseoff);
9762     TREE_CHAIN (baseoff) = list;
9763
9764     numelem = build_tree_list (NULL_TREE, numelem);
9765     TREE_CHAIN (numelem) = baseoff;
9766
9767     numdim = build_tree_list (NULL_TREE, numdim);
9768     TREE_CHAIN (numdim) = numelem;
9769
9770     yes = suspend_momentary ();
9771
9772     item = build_array_type (ffecom_f2c_ftnlen_type_node,
9773                              build_range_type (integer_type_node,
9774                                                integer_zero_node,
9775                                                build_int_2
9776                                                ((int) ffesymbol_rank (s)
9777                                                 + 2, 0)));
9778     list = build (CONSTRUCTOR, item, NULL_TREE, numdim);
9779     TREE_CONSTANT (list) = 1;
9780     TREE_STATIC (list) = 1;
9781
9782     var = ffecom_get_invented_identifier ("__g77_dims_%d", mynumber++);
9783     var = build_decl (VAR_DECL, var, item);
9784     TREE_STATIC (var) = 1;
9785     DECL_INITIAL (var) = error_mark_node;
9786     var = start_decl (var, FALSE);
9787     finish_decl (var, list, FALSE);
9788
9789     var = ffecom_1 (ADDR_EXPR, build_pointer_type (item), var);
9790
9791     resume_momentary (yes);
9792
9793     return var;
9794   }
9795 }
9796
9797 #endif
9798 /* Essentially does a "fold (build1 (code, type, node))" while checking
9799    for certain housekeeping things.
9800
9801    NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
9802    ffecom_1_fn instead.  */
9803
9804 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9805 tree
9806 ffecom_1 (enum tree_code code, tree type, tree node)
9807 {
9808   tree item;
9809
9810   if ((node == error_mark_node)
9811       || (type == error_mark_node))
9812     return error_mark_node;
9813
9814   if (code == ADDR_EXPR)
9815     {
9816       if (!mark_addressable (node))
9817         assert ("can't mark_addressable this node!" == NULL);
9818     }
9819
9820   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9821     {
9822       tree realtype;
9823
9824     case REALPART_EXPR:
9825       item = build (COMPONENT_REF, type, node, TYPE_FIELDS (TREE_TYPE (node)));
9826       break;
9827
9828     case IMAGPART_EXPR:
9829       item = build (COMPONENT_REF, type, node, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node))));
9830       break;
9831
9832
9833     case NEGATE_EXPR:
9834       if (TREE_CODE (type) != RECORD_TYPE)
9835         {
9836           item = build1 (code, type, node);
9837           break;
9838         }
9839       node = ffecom_stabilize_aggregate_ (node);
9840       realtype = TREE_TYPE (TYPE_FIELDS (type));
9841       item =
9842         ffecom_2 (COMPLEX_EXPR, type,
9843                   ffecom_1 (NEGATE_EXPR, realtype,
9844                             ffecom_1 (REALPART_EXPR, realtype,
9845                                       node)),
9846                   ffecom_1 (NEGATE_EXPR, realtype,
9847                             ffecom_1 (IMAGPART_EXPR, realtype,
9848                                       node)));
9849       break;
9850
9851     default:
9852       item = build1 (code, type, node);
9853       break;
9854     }
9855
9856   if (TREE_SIDE_EFFECTS (node))
9857     TREE_SIDE_EFFECTS (item) = 1;
9858   if ((code == ADDR_EXPR) && staticp (node))
9859     TREE_CONSTANT (item) = 1;
9860   return fold (item);
9861 }
9862 #endif
9863
9864 /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
9865    handles TREE_CODE (node) == FUNCTION_DECL.  In particular,
9866    does not set TREE_ADDRESSABLE (because calling an inline
9867    function does not mean the function needs to be separately
9868    compiled).  */
9869
9870 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9871 tree
9872 ffecom_1_fn (tree node)
9873 {
9874   tree item;
9875   tree type;
9876
9877   if (node == error_mark_node)
9878     return error_mark_node;
9879
9880   type = build_type_variant (TREE_TYPE (node),
9881                              TREE_READONLY (node),
9882                              TREE_THIS_VOLATILE (node));
9883   item = build1 (ADDR_EXPR,
9884                  build_pointer_type (type), node);
9885   if (TREE_SIDE_EFFECTS (node))
9886     TREE_SIDE_EFFECTS (item) = 1;
9887   if (staticp (node))
9888     TREE_CONSTANT (item) = 1;
9889   return fold (item);
9890 }
9891 #endif
9892
9893 /* Essentially does a "fold (build (code, type, node1, node2))" while
9894    checking for certain housekeeping things.  */
9895
9896 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9897 tree
9898 ffecom_2 (enum tree_code code, tree type, tree node1,
9899           tree node2)
9900 {
9901   tree item;
9902
9903   if ((node1 == error_mark_node)
9904       || (node2 == error_mark_node)
9905       || (type == error_mark_node))
9906     return error_mark_node;
9907
9908   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9909     {
9910       tree a, b, c, d, realtype;
9911
9912     case CONJ_EXPR:
9913       assert ("no CONJ_EXPR support yet" == NULL);
9914       return error_mark_node;
9915
9916     case COMPLEX_EXPR:
9917       item = build_tree_list (TYPE_FIELDS (type), node1);
9918       TREE_CHAIN (item) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), node2);
9919       item = build (CONSTRUCTOR, type, NULL_TREE, item);
9920       break;
9921
9922     case PLUS_EXPR:
9923       if (TREE_CODE (type) != RECORD_TYPE)
9924         {
9925           item = build (code, type, node1, node2);
9926           break;
9927         }
9928       node1 = ffecom_stabilize_aggregate_ (node1);
9929       node2 = ffecom_stabilize_aggregate_ (node2);
9930       realtype = TREE_TYPE (TYPE_FIELDS (type));
9931       item =
9932         ffecom_2 (COMPLEX_EXPR, type,
9933                   ffecom_2 (PLUS_EXPR, realtype,
9934                             ffecom_1 (REALPART_EXPR, realtype,
9935                                       node1),
9936                             ffecom_1 (REALPART_EXPR, realtype,
9937                                       node2)),
9938                   ffecom_2 (PLUS_EXPR, realtype,
9939                             ffecom_1 (IMAGPART_EXPR, realtype,
9940                                       node1),
9941                             ffecom_1 (IMAGPART_EXPR, realtype,
9942                                       node2)));
9943       break;
9944
9945     case MINUS_EXPR:
9946       if (TREE_CODE (type) != RECORD_TYPE)
9947         {
9948           item = build (code, type, node1, node2);
9949           break;
9950         }
9951       node1 = ffecom_stabilize_aggregate_ (node1);
9952       node2 = ffecom_stabilize_aggregate_ (node2);
9953       realtype = TREE_TYPE (TYPE_FIELDS (type));
9954       item =
9955         ffecom_2 (COMPLEX_EXPR, type,
9956                   ffecom_2 (MINUS_EXPR, realtype,
9957                             ffecom_1 (REALPART_EXPR, realtype,
9958                                       node1),
9959                             ffecom_1 (REALPART_EXPR, realtype,
9960                                       node2)),
9961                   ffecom_2 (MINUS_EXPR, realtype,
9962                             ffecom_1 (IMAGPART_EXPR, realtype,
9963                                       node1),
9964                             ffecom_1 (IMAGPART_EXPR, realtype,
9965                                       node2)));
9966       break;
9967
9968     case MULT_EXPR:
9969       if (TREE_CODE (type) != RECORD_TYPE)
9970         {
9971           item = build (code, type, node1, node2);
9972           break;
9973         }
9974       node1 = ffecom_stabilize_aggregate_ (node1);
9975       node2 = ffecom_stabilize_aggregate_ (node2);
9976       realtype = TREE_TYPE (TYPE_FIELDS (type));
9977       a = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9978                                node1));
9979       b = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9980                                node1));
9981       c = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9982                                node2));
9983       d = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9984                                node2));
9985       item =
9986         ffecom_2 (COMPLEX_EXPR, type,
9987                   ffecom_2 (MINUS_EXPR, realtype,
9988                             ffecom_2 (MULT_EXPR, realtype,
9989                                       a,
9990                                       c),
9991                             ffecom_2 (MULT_EXPR, realtype,
9992                                       b,
9993                                       d)),
9994                   ffecom_2 (PLUS_EXPR, realtype,
9995                             ffecom_2 (MULT_EXPR, realtype,
9996                                       a,
9997                                       d),
9998                             ffecom_2 (MULT_EXPR, realtype,
9999                                       c,
10000                                       b)));
10001       break;
10002
10003     case EQ_EXPR:
10004       if ((TREE_CODE (node1) != RECORD_TYPE)
10005           && (TREE_CODE (node2) != RECORD_TYPE))
10006         {
10007           item = build (code, type, node1, node2);
10008           break;
10009         }
10010       assert (TREE_CODE (node1) == RECORD_TYPE);
10011       assert (TREE_CODE (node2) == RECORD_TYPE);
10012       node1 = ffecom_stabilize_aggregate_ (node1);
10013       node2 = ffecom_stabilize_aggregate_ (node2);
10014       realtype = TREE_TYPE (TYPE_FIELDS (type));
10015       item =
10016         ffecom_2 (TRUTH_ANDIF_EXPR, type,
10017                   ffecom_2 (code, type,
10018                             ffecom_1 (REALPART_EXPR, realtype,
10019                                       node1),
10020                             ffecom_1 (REALPART_EXPR, realtype,
10021                                       node2)),
10022                   ffecom_2 (code, type,
10023                             ffecom_1 (IMAGPART_EXPR, realtype,
10024                                       node1),
10025                             ffecom_1 (IMAGPART_EXPR, realtype,
10026                                       node2)));
10027       break;
10028
10029     case NE_EXPR:
10030       if ((TREE_CODE (node1) != RECORD_TYPE)
10031           && (TREE_CODE (node2) != RECORD_TYPE))
10032         {
10033           item = build (code, type, node1, node2);
10034           break;
10035         }
10036       assert (TREE_CODE (node1) == RECORD_TYPE);
10037       assert (TREE_CODE (node2) == RECORD_TYPE);
10038       node1 = ffecom_stabilize_aggregate_ (node1);
10039       node2 = ffecom_stabilize_aggregate_ (node2);
10040       realtype = TREE_TYPE (TYPE_FIELDS (type));
10041       item =
10042         ffecom_2 (TRUTH_ORIF_EXPR, type,
10043                   ffecom_2 (code, type,
10044                             ffecom_1 (REALPART_EXPR, realtype,
10045                                       node1),
10046                             ffecom_1 (REALPART_EXPR, realtype,
10047                                       node2)),
10048                   ffecom_2 (code, type,
10049                             ffecom_1 (IMAGPART_EXPR, realtype,
10050                                       node1),
10051                             ffecom_1 (IMAGPART_EXPR, realtype,
10052                                       node2)));
10053       break;
10054
10055     default:
10056       item = build (code, type, node1, node2);
10057       break;
10058     }
10059
10060   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2))
10061     TREE_SIDE_EFFECTS (item) = 1;
10062   return fold (item);
10063 }
10064
10065 #endif
10066 /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
10067
10068    ffesymbol s;  // the ENTRY point itself
10069    if (ffecom_2pass_advise_entrypoint(s))
10070        // the ENTRY point has been accepted
10071
10072    Does whatever compiler needs to do when it learns about the entrypoint,
10073    like determine the return type of the master function, count the
10074    number of entrypoints, etc.  Returns FALSE if the return type is
10075    not compatible with the return type(s) of other entrypoint(s).
10076
10077    NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
10078    later (after _finish_progunit) be called with the same entrypoint(s)
10079    as passed to this fn for which TRUE was returned.
10080
10081    03-Jan-92  JCB  2.0
10082       Return FALSE if the return type conflicts with previous entrypoints.  */
10083
10084 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10085 bool
10086 ffecom_2pass_advise_entrypoint (ffesymbol entry)
10087 {
10088   ffebld list;                  /* opITEM. */
10089   ffebld mlist;                 /* opITEM. */
10090   ffebld plist;                 /* opITEM. */
10091   ffebld arg;                   /* ffebld_head(opITEM). */
10092   ffebld item;                  /* opITEM. */
10093   ffesymbol s;                  /* ffebld_symter(arg). */
10094   ffeinfoBasictype bt = ffesymbol_basictype (entry);
10095   ffeinfoKindtype kt = ffesymbol_kindtype (entry);
10096   ffetargetCharacterSize size = ffesymbol_size (entry);
10097   bool ok;
10098
10099   if (ffecom_num_entrypoints_ == 0)
10100     {                           /* First entrypoint, make list of main
10101                                    arglist's dummies. */
10102       assert (ffecom_primary_entry_ != NULL);
10103
10104       ffecom_master_bt_ = ffesymbol_basictype (ffecom_primary_entry_);
10105       ffecom_master_kt_ = ffesymbol_kindtype (ffecom_primary_entry_);
10106       ffecom_master_size_ = ffesymbol_size (ffecom_primary_entry_);
10107
10108       for (plist = NULL, list = ffesymbol_dummyargs (ffecom_primary_entry_);
10109            list != NULL;
10110            list = ffebld_trail (list))
10111         {
10112           arg = ffebld_head (list);
10113           if (ffebld_op (arg) != FFEBLD_opSYMTER)
10114             continue;           /* Alternate return or some such thing. */
10115           item = ffebld_new_item (arg, NULL);
10116           if (plist == NULL)
10117             ffecom_master_arglist_ = item;
10118           else
10119             ffebld_set_trail (plist, item);
10120           plist = item;
10121         }
10122     }
10123
10124   /* If necessary, scan entry arglist for alternate returns.  Do this scan
10125      apparently redundantly (it's done below to UNIONize the arglists) so
10126      that we don't complain about RETURN 1 if an offending ENTRY is the only
10127      one with an alternate return.  */
10128
10129   if (!ffecom_is_altreturning_)
10130     {
10131       for (list = ffesymbol_dummyargs (entry);
10132            list != NULL;
10133            list = ffebld_trail (list))
10134         {
10135           arg = ffebld_head (list);
10136           if (ffebld_op (arg) == FFEBLD_opSTAR)
10137             {
10138               ffecom_is_altreturning_ = TRUE;
10139               break;
10140             }
10141         }
10142     }
10143
10144   /* Now check type compatibility. */
10145
10146   switch (ffecom_master_bt_)
10147     {
10148     case FFEINFO_basictypeNONE:
10149       ok = (bt != FFEINFO_basictypeCHARACTER);
10150       break;
10151
10152     case FFEINFO_basictypeCHARACTER:
10153       ok
10154         = (bt == FFEINFO_basictypeCHARACTER)
10155         && (kt == ffecom_master_kt_)
10156         && (size == ffecom_master_size_);
10157       break;
10158
10159     case FFEINFO_basictypeANY:
10160       return FALSE;             /* Just don't bother. */
10161
10162     default:
10163       if (bt == FFEINFO_basictypeCHARACTER)
10164         {
10165           ok = FALSE;
10166           break;
10167         }
10168       ok = TRUE;
10169       if ((bt != ffecom_master_bt_) || (kt != ffecom_master_kt_))
10170         {
10171           ffecom_master_bt_ = FFEINFO_basictypeNONE;
10172           ffecom_master_kt_ = FFEINFO_kindtypeNONE;
10173         }
10174       break;
10175     }
10176
10177   if (!ok)
10178     {
10179       ffebad_start (FFEBAD_ENTRY_CONFLICTS);
10180       ffest_ffebad_here_current_stmt (0);
10181       ffebad_finish ();
10182       return FALSE;             /* Can't handle entrypoint. */
10183     }
10184
10185   /* Entrypoint type compatible with previous types. */
10186
10187   ++ffecom_num_entrypoints_;
10188
10189   /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
10190
10191   for (list = ffesymbol_dummyargs (entry);
10192        list != NULL;
10193        list = ffebld_trail (list))
10194     {
10195       arg = ffebld_head (list);
10196       if (ffebld_op (arg) != FFEBLD_opSYMTER)
10197         continue;               /* Alternate return or some such thing. */
10198       s = ffebld_symter (arg);
10199       for (plist = NULL, mlist = ffecom_master_arglist_;
10200            mlist != NULL;
10201            plist = mlist, mlist = ffebld_trail (mlist))
10202         {                       /* plist points to previous item for easy
10203                                    appending of arg. */
10204           if (ffebld_symter (ffebld_head (mlist)) == s)
10205             break;              /* Already have this arg in the master list. */
10206         }
10207       if (mlist != NULL)
10208         continue;               /* Already have this arg in the master list. */
10209
10210       /* Append this arg to the master list. */
10211
10212       item = ffebld_new_item (arg, NULL);
10213       if (plist == NULL)
10214         ffecom_master_arglist_ = item;
10215       else
10216         ffebld_set_trail (plist, item);
10217     }
10218
10219   return TRUE;
10220 }
10221
10222 #endif
10223 /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
10224
10225    ffesymbol s;  // the ENTRY point itself
10226    ffecom_2pass_do_entrypoint(s);
10227
10228    Does whatever compiler needs to do to make the entrypoint actually
10229    happen.  Must be called for each entrypoint after
10230    ffecom_finish_progunit is called.  */
10231
10232 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10233 void
10234 ffecom_2pass_do_entrypoint (ffesymbol entry)
10235 {
10236   static int mfn_num = 0;
10237   static int ent_num;
10238
10239   if (mfn_num != ffecom_num_fns_)
10240     {                           /* First entrypoint for this program unit. */
10241       ent_num = 1;
10242       mfn_num = ffecom_num_fns_;
10243       ffecom_do_entry_ (ffecom_primary_entry_, 0);
10244     }
10245   else
10246     ++ent_num;
10247
10248   --ffecom_num_entrypoints_;
10249
10250   ffecom_do_entry_ (entry, ent_num);
10251 }
10252
10253 #endif
10254
10255 /* Essentially does a "fold (build (code, type, node1, node2))" while
10256    checking for certain housekeeping things.  Always sets
10257    TREE_SIDE_EFFECTS.  */
10258
10259 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10260 tree
10261 ffecom_2s (enum tree_code code, tree type, tree node1,
10262            tree node2)
10263 {
10264   tree item;
10265
10266   if ((node1 == error_mark_node)
10267       || (node2 == error_mark_node)
10268       || (type == error_mark_node))
10269     return error_mark_node;
10270
10271   item = build (code, type, node1, node2);
10272   TREE_SIDE_EFFECTS (item) = 1;
10273   return fold (item);
10274 }
10275
10276 #endif
10277 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10278    checking for certain housekeeping things.  */
10279
10280 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10281 tree
10282 ffecom_3 (enum tree_code code, tree type, tree node1,
10283           tree node2, tree node3)
10284 {
10285   tree item;
10286
10287   if ((node1 == error_mark_node)
10288       || (node2 == error_mark_node)
10289       || (node3 == error_mark_node)
10290       || (type == error_mark_node))
10291     return error_mark_node;
10292
10293   item = build (code, type, node1, node2, node3);
10294   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2)
10295       || (node3 != NULL_TREE && TREE_SIDE_EFFECTS (node3)))
10296     TREE_SIDE_EFFECTS (item) = 1;
10297   return fold (item);
10298 }
10299
10300 #endif
10301 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10302    checking for certain housekeeping things.  Always sets
10303    TREE_SIDE_EFFECTS.  */
10304
10305 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10306 tree
10307 ffecom_3s (enum tree_code code, tree type, tree node1,
10308            tree node2, tree node3)
10309 {
10310   tree item;
10311
10312   if ((node1 == error_mark_node)
10313       || (node2 == error_mark_node)
10314       || (node3 == error_mark_node)
10315       || (type == error_mark_node))
10316     return error_mark_node;
10317
10318   item = build (code, type, node1, node2, node3);
10319   TREE_SIDE_EFFECTS (item) = 1;
10320   return fold (item);
10321 }
10322
10323 #endif
10324
10325 /* ffecom_arg_expr -- Transform argument expr into gcc tree
10326
10327    See use by ffecom_list_expr.
10328
10329    If expression is NULL, returns an integer zero tree.  If it is not
10330    a CHARACTER expression, returns whatever ffecom_expr
10331    returns and sets the length return value to NULL_TREE.  Otherwise
10332    generates code to evaluate the character expression, returns the proper
10333    pointer to the result, but does NOT set the length return value to a tree
10334    that specifies the length of the result.  (In other words, the length
10335    variable is always set to NULL_TREE, because a length is never passed.)
10336
10337    21-Dec-91  JCB  1.1
10338       Don't set returned length, since nobody needs it (yet; someday if
10339       we allow CHARACTER*(*) dummies to statement functions, we'll need
10340       it).  */
10341
10342 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10343 tree
10344 ffecom_arg_expr (ffebld expr, tree *length)
10345 {
10346   tree ign;
10347
10348   *length = NULL_TREE;
10349
10350   if (expr == NULL)
10351     return integer_zero_node;
10352
10353   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10354     return ffecom_expr (expr);
10355
10356   return ffecom_arg_ptr_to_expr (expr, &ign);
10357 }
10358
10359 #endif
10360 /* Transform expression into constant argument-pointer-to-expression tree.
10361
10362    If the expression can be transformed into a argument-pointer-to-expression
10363    tree that is constant, that is done, and the tree returned.  Else
10364    NULL_TREE is returned.
10365
10366    That way, a caller can attempt to provide compile-time initialization
10367    of a variable and, if that fails, *then* choose to start a new block
10368    and resort to using temporaries, as appropriate.  */
10369
10370 tree
10371 ffecom_arg_ptr_to_const_expr (ffebld expr, tree *length)
10372 {
10373   if (! expr)
10374     return integer_zero_node;
10375
10376   if (ffebld_op (expr) == FFEBLD_opANY)
10377     {
10378       if (length)
10379         *length = error_mark_node;
10380       return error_mark_node;
10381     }
10382
10383   if (ffebld_arity (expr) == 0
10384       && (ffebld_op (expr) != FFEBLD_opSYMTER
10385           || ffebld_where (expr) == FFEINFO_whereCOMMON
10386           || ffebld_where (expr) == FFEINFO_whereGLOBAL
10387           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10388     {
10389       tree t;
10390
10391       t = ffecom_arg_ptr_to_expr (expr, length);
10392       assert (TREE_CONSTANT (t));
10393       assert (! length || TREE_CONSTANT (*length));
10394       return t;
10395     }
10396
10397   if (length
10398       && ffebld_size (expr) != FFETARGET_charactersizeNONE)
10399     *length = build_int_2 (ffebld_size (expr), 0);
10400   else if (length)
10401     *length = NULL_TREE;
10402   return NULL_TREE;
10403 }
10404
10405 /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
10406
10407    See use by ffecom_list_ptr_to_expr.
10408
10409    If expression is NULL, returns an integer zero tree.  If it is not
10410    a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10411    returns and sets the length return value to NULL_TREE.  Otherwise
10412    generates code to evaluate the character expression, returns the proper
10413    pointer to the result, AND sets the length return value to a tree that
10414    specifies the length of the result.
10415
10416    If the length argument is NULL, this is a slightly special
10417    case of building a FORMAT expression, that is, an expression that
10418    will be used at run time without regard to length.  For the current
10419    implementation, which uses the libf2c library, this means it is nice
10420    to append a null byte to the end of the expression, where feasible,
10421    to make sure any diagnostic about the FORMAT string terminates at
10422    some useful point.
10423
10424    For now, treat %REF(char-expr) as the same as char-expr with a NULL
10425    length argument.  This might even be seen as a feature, if a null
10426    byte can always be appended.  */
10427
10428 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10429 tree
10430 ffecom_arg_ptr_to_expr (ffebld expr, tree *length)
10431 {
10432   tree item;
10433   tree ign_length;
10434   ffecomConcatList_ catlist;
10435
10436   if (length != NULL)
10437     *length = NULL_TREE;
10438
10439   if (expr == NULL)
10440     return integer_zero_node;
10441
10442   switch (ffebld_op (expr))
10443     {
10444     case FFEBLD_opPERCENT_VAL:
10445       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10446         return ffecom_expr (ffebld_left (expr));
10447       {
10448         tree temp_exp;
10449         tree temp_length;
10450
10451         temp_exp = ffecom_arg_ptr_to_expr (ffebld_left (expr), &temp_length);
10452         if (temp_exp == error_mark_node)
10453           return error_mark_node;
10454
10455         return ffecom_1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (temp_exp)),
10456                          temp_exp);
10457       }
10458
10459     case FFEBLD_opPERCENT_REF:
10460       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10461         return ffecom_ptr_to_expr (ffebld_left (expr));
10462       if (length != NULL)
10463         {
10464           ign_length = NULL_TREE;
10465           length = &ign_length;
10466         }
10467       expr = ffebld_left (expr);
10468       break;
10469
10470     case FFEBLD_opPERCENT_DESCR:
10471       switch (ffeinfo_basictype (ffebld_info (expr)))
10472         {
10473 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10474         case FFEINFO_basictypeHOLLERITH:
10475 #endif
10476         case FFEINFO_basictypeCHARACTER:
10477           break;                /* Passed by descriptor anyway. */
10478
10479         default:
10480           item = ffecom_ptr_to_expr (expr);
10481           if (item != error_mark_node)
10482             *length = TYPE_SIZE (TREE_TYPE (TREE_TYPE (item)));
10483           break;
10484         }
10485       break;
10486
10487     default:
10488       break;
10489     }
10490
10491 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10492   if ((ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeHOLLERITH)
10493       && (length != NULL))
10494     {                           /* Pass Hollerith by descriptor. */
10495       ffetargetHollerith h;
10496
10497       assert (ffebld_op (expr) == FFEBLD_opCONTER);
10498       h = ffebld_cu_val_hollerith (ffebld_constant_union
10499                                    (ffebld_conter (expr)));
10500       *length
10501         = build_int_2 (h.length, 0);
10502       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10503     }
10504 #endif
10505
10506   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10507     return ffecom_ptr_to_expr (expr);
10508
10509   assert (ffeinfo_kindtype (ffebld_info (expr))
10510           == FFEINFO_kindtypeCHARACTER1);
10511
10512   while (ffebld_op (expr) == FFEBLD_opPAREN)
10513     expr = ffebld_left (expr);
10514
10515   catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
10516   switch (ffecom_concat_list_count_ (catlist))
10517     {
10518     case 0:                     /* Shouldn't happen, but in case it does... */
10519       if (length != NULL)
10520         {
10521           *length = ffecom_f2c_ftnlen_zero_node;
10522           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10523         }
10524       ffecom_concat_list_kill_ (catlist);
10525       return null_pointer_node;
10526
10527     case 1:                     /* The (fairly) easy case. */
10528       if (length == NULL)
10529         ffecom_char_args_with_null_ (&item, &ign_length,
10530                                      ffecom_concat_list_expr_ (catlist, 0));
10531       else
10532         ffecom_char_args_ (&item, length,
10533                            ffecom_concat_list_expr_ (catlist, 0));
10534       ffecom_concat_list_kill_ (catlist);
10535       assert (item != NULL_TREE);
10536       return item;
10537
10538     default:                    /* Must actually concatenate things. */
10539       break;
10540     }
10541
10542   {
10543     int count = ffecom_concat_list_count_ (catlist);
10544     int i;
10545     tree lengths;
10546     tree items;
10547     tree length_array;
10548     tree item_array;
10549     tree citem;
10550     tree clength;
10551     tree temporary;
10552     tree num;
10553     tree known_length;
10554     ffetargetCharacterSize sz;
10555
10556     sz = ffecom_concat_list_maxlen_ (catlist);
10557     /* ~~Kludge! */
10558     assert (sz != FFETARGET_charactersizeNONE);
10559
10560 #ifdef HOHO
10561     length_array
10562       = lengths
10563       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
10564                              FFETARGET_charactersizeNONE, count, TRUE);
10565     item_array
10566       = items
10567       = ffecom_push_tempvar (ffecom_f2c_address_type_node,
10568                              FFETARGET_charactersizeNONE, count, TRUE);
10569     temporary = ffecom_push_tempvar (char_type_node,
10570                                      sz, -1, TRUE);
10571 #else
10572     {
10573       tree hook;
10574
10575       hook = ffebld_nonter_hook (expr);
10576       assert (hook);
10577       assert (TREE_CODE (hook) == TREE_VEC);
10578       assert (TREE_VEC_LENGTH (hook) == 3);
10579       length_array = lengths = TREE_VEC_ELT (hook, 0);
10580       item_array = items = TREE_VEC_ELT (hook, 1);
10581       temporary = TREE_VEC_ELT (hook, 2);
10582     }
10583 #endif
10584
10585     known_length = ffecom_f2c_ftnlen_zero_node;
10586
10587     for (i = 0; i < count; ++i)
10588       {
10589         if ((i == count)
10590             && (length == NULL))
10591           ffecom_char_args_with_null_ (&citem, &clength,
10592                                        ffecom_concat_list_expr_ (catlist, i));
10593         else
10594           ffecom_char_args_ (&citem, &clength,
10595                              ffecom_concat_list_expr_ (catlist, i));
10596         if ((citem == error_mark_node)
10597             || (clength == error_mark_node))
10598           {
10599             ffecom_concat_list_kill_ (catlist);
10600             *length = error_mark_node;
10601             return error_mark_node;
10602           }
10603
10604         items
10605           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
10606                       ffecom_modify (void_type_node,
10607                                      ffecom_2 (ARRAY_REF,
10608                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
10609                                                item_array,
10610                                                build_int_2 (i, 0)),
10611                                      citem),
10612                       items);
10613         clength = ffecom_save_tree (clength);
10614         if (length != NULL)
10615           known_length
10616             = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
10617                         known_length,
10618                         clength);
10619         lengths
10620           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
10621                       ffecom_modify (void_type_node,
10622                                      ffecom_2 (ARRAY_REF,
10623                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
10624                                                length_array,
10625                                                build_int_2 (i, 0)),
10626                                      clength),
10627                       lengths);
10628       }
10629
10630     temporary = ffecom_1 (ADDR_EXPR,
10631                           build_pointer_type (TREE_TYPE (temporary)),
10632                           temporary);
10633
10634     item = build_tree_list (NULL_TREE, temporary);
10635     TREE_CHAIN (item)
10636       = build_tree_list (NULL_TREE,
10637                          ffecom_1 (ADDR_EXPR,
10638                                    build_pointer_type (TREE_TYPE (items)),
10639                                    items));
10640     TREE_CHAIN (TREE_CHAIN (item))
10641       = build_tree_list (NULL_TREE,
10642                          ffecom_1 (ADDR_EXPR,
10643                                    build_pointer_type (TREE_TYPE (lengths)),
10644                                    lengths));
10645     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
10646       = build_tree_list
10647         (NULL_TREE,
10648          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
10649                    convert (ffecom_f2c_ftnlen_type_node,
10650                             build_int_2 (count, 0))));
10651     num = build_int_2 (sz, 0);
10652     TREE_TYPE (num) = ffecom_f2c_ftnlen_type_node;
10653     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item))))
10654       = build_tree_list (NULL_TREE, num);
10655
10656     item = ffecom_call_gfrt (FFECOM_gfrtCAT, item, NULL_TREE);
10657     TREE_SIDE_EFFECTS (item) = 1;
10658     item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (temporary),
10659                      item,
10660                      temporary);
10661
10662     if (length != NULL)
10663       *length = known_length;
10664   }
10665
10666   ffecom_concat_list_kill_ (catlist);
10667   assert (item != NULL_TREE);
10668   return item;
10669 }
10670
10671 #endif
10672 /* Generate call to run-time function.
10673
10674    The first arg is the GNU Fortran Run-Time function index, the second
10675    arg is the list of arguments to pass to it.  Returned is the expression
10676    (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
10677    result (which may be void).  */
10678
10679 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10680 tree
10681 ffecom_call_gfrt (ffecomGfrt ix, tree args, tree hook)
10682 {
10683   return ffecom_call_ (ffecom_gfrt_tree_ (ix),
10684                        ffecom_gfrt_kindtype (ix),
10685                        ffe_is_f2c_library () && ffecom_gfrt_complex_[ix],
10686                        NULL_TREE, args, NULL_TREE, NULL,
10687                        NULL, NULL_TREE, TRUE, hook);
10688 }
10689 #endif
10690
10691 /* Transform constant-union to tree.  */
10692
10693 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10694 tree
10695 ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt,
10696                       ffeinfoKindtype kt, tree tree_type)
10697 {
10698   tree item;
10699
10700   switch (bt)
10701     {
10702     case FFEINFO_basictypeINTEGER:
10703       {
10704         int val;
10705
10706         switch (kt)
10707           {
10708 #if FFETARGET_okINTEGER1
10709           case FFEINFO_kindtypeINTEGER1:
10710             val = ffebld_cu_val_integer1 (*cu);
10711             break;
10712 #endif
10713
10714 #if FFETARGET_okINTEGER2
10715           case FFEINFO_kindtypeINTEGER2:
10716             val = ffebld_cu_val_integer2 (*cu);
10717             break;
10718 #endif
10719
10720 #if FFETARGET_okINTEGER3
10721           case FFEINFO_kindtypeINTEGER3:
10722             val = ffebld_cu_val_integer3 (*cu);
10723             break;
10724 #endif
10725
10726 #if FFETARGET_okINTEGER4
10727           case FFEINFO_kindtypeINTEGER4:
10728             val = ffebld_cu_val_integer4 (*cu);
10729             break;
10730 #endif
10731
10732           default:
10733             assert ("bad INTEGER constant kind type" == NULL);
10734             /* Fall through. */
10735           case FFEINFO_kindtypeANY:
10736             return error_mark_node;
10737           }
10738         item = build_int_2 (val, (val < 0) ? -1 : 0);
10739         TREE_TYPE (item) = tree_type;
10740       }
10741       break;
10742
10743     case FFEINFO_basictypeLOGICAL:
10744       {
10745         int val;
10746
10747         switch (kt)
10748           {
10749 #if FFETARGET_okLOGICAL1
10750           case FFEINFO_kindtypeLOGICAL1:
10751             val = ffebld_cu_val_logical1 (*cu);
10752             break;
10753 #endif
10754
10755 #if FFETARGET_okLOGICAL2
10756           case FFEINFO_kindtypeLOGICAL2:
10757             val = ffebld_cu_val_logical2 (*cu);
10758             break;
10759 #endif
10760
10761 #if FFETARGET_okLOGICAL3
10762           case FFEINFO_kindtypeLOGICAL3:
10763             val = ffebld_cu_val_logical3 (*cu);
10764             break;
10765 #endif
10766
10767 #if FFETARGET_okLOGICAL4
10768           case FFEINFO_kindtypeLOGICAL4:
10769             val = ffebld_cu_val_logical4 (*cu);
10770             break;
10771 #endif
10772
10773           default:
10774             assert ("bad LOGICAL constant kind type" == NULL);
10775             /* Fall through. */
10776           case FFEINFO_kindtypeANY:
10777             return error_mark_node;
10778           }
10779         item = build_int_2 (val, (val < 0) ? -1 : 0);
10780         TREE_TYPE (item) = tree_type;
10781       }
10782       break;
10783
10784     case FFEINFO_basictypeREAL:
10785       {
10786         REAL_VALUE_TYPE val;
10787
10788         switch (kt)
10789           {
10790 #if FFETARGET_okREAL1
10791           case FFEINFO_kindtypeREAL1:
10792             val = ffetarget_value_real1 (ffebld_cu_val_real1 (*cu));
10793             break;
10794 #endif
10795
10796 #if FFETARGET_okREAL2
10797           case FFEINFO_kindtypeREAL2:
10798             val = ffetarget_value_real2 (ffebld_cu_val_real2 (*cu));
10799             break;
10800 #endif
10801
10802 #if FFETARGET_okREAL3
10803           case FFEINFO_kindtypeREAL3:
10804             val = ffetarget_value_real3 (ffebld_cu_val_real3 (*cu));
10805             break;
10806 #endif
10807
10808 #if FFETARGET_okREAL4
10809           case FFEINFO_kindtypeREAL4:
10810             val = ffetarget_value_real4 (ffebld_cu_val_real4 (*cu));
10811             break;
10812 #endif
10813
10814           default:
10815             assert ("bad REAL constant kind type" == NULL);
10816             /* Fall through. */
10817           case FFEINFO_kindtypeANY:
10818             return error_mark_node;
10819           }
10820         item = build_real (tree_type, val);
10821       }
10822       break;
10823
10824     case FFEINFO_basictypeCOMPLEX:
10825       {
10826         REAL_VALUE_TYPE real;
10827         REAL_VALUE_TYPE imag;
10828         tree el_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
10829
10830         switch (kt)
10831           {
10832 #if FFETARGET_okCOMPLEX1
10833           case FFEINFO_kindtypeREAL1:
10834             real = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).real);
10835             imag = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).imaginary);
10836             break;
10837 #endif
10838
10839 #if FFETARGET_okCOMPLEX2
10840           case FFEINFO_kindtypeREAL2:
10841             real = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).real);
10842             imag = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).imaginary);
10843             break;
10844 #endif
10845
10846 #if FFETARGET_okCOMPLEX3
10847           case FFEINFO_kindtypeREAL3:
10848             real = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).real);
10849             imag = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).imaginary);
10850             break;
10851 #endif
10852
10853 #if FFETARGET_okCOMPLEX4
10854           case FFEINFO_kindtypeREAL4:
10855             real = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).real);
10856             imag = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).imaginary);
10857             break;
10858 #endif
10859
10860           default:
10861             assert ("bad REAL constant kind type" == NULL);
10862             /* Fall through. */
10863           case FFEINFO_kindtypeANY:
10864             return error_mark_node;
10865           }
10866         item = ffecom_build_complex_constant_ (tree_type,
10867                                                build_real (el_type, real),
10868                                                build_real (el_type, imag));
10869       }
10870       break;
10871
10872     case FFEINFO_basictypeCHARACTER:
10873       {                         /* Happens only in DATA and similar contexts. */
10874         ffetargetCharacter1 val;
10875
10876         switch (kt)
10877           {
10878 #if FFETARGET_okCHARACTER1
10879           case FFEINFO_kindtypeLOGICAL1:
10880             val = ffebld_cu_val_character1 (*cu);
10881             break;
10882 #endif
10883
10884           default:
10885             assert ("bad CHARACTER constant kind type" == NULL);
10886             /* Fall through. */
10887           case FFEINFO_kindtypeANY:
10888             return error_mark_node;
10889           }
10890         item = build_string (ffetarget_length_character1 (val),
10891                              ffetarget_text_character1 (val));
10892         TREE_TYPE (item)
10893           = build_type_variant (build_array_type (char_type_node,
10894                                                   build_range_type
10895                                                   (integer_type_node,
10896                                                    integer_one_node,
10897                                                    build_int_2
10898                                                 (ffetarget_length_character1
10899                                                  (val), 0))),
10900                                 1, 0);
10901       }
10902       break;
10903
10904     case FFEINFO_basictypeHOLLERITH:
10905       {
10906         ffetargetHollerith h;
10907
10908         h = ffebld_cu_val_hollerith (*cu);
10909
10910         /* If not at least as wide as default INTEGER, widen it.  */
10911         if (h.length >= FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE)
10912           item = build_string (h.length, h.text);
10913         else
10914           {
10915             char str[FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE];
10916
10917             memcpy (str, h.text, h.length);
10918             memset (&str[h.length], ' ',
10919                     FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE
10920                     - h.length);
10921             item = build_string (FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE,
10922                                  str);
10923           }
10924         TREE_TYPE (item)
10925           = build_type_variant (build_array_type (char_type_node,
10926                                                   build_range_type
10927                                                   (integer_type_node,
10928                                                    integer_one_node,
10929                                                    build_int_2
10930                                                    (h.length, 0))),
10931                                 1, 0);
10932       }
10933       break;
10934
10935     case FFEINFO_basictypeTYPELESS:
10936       {
10937         ffetargetInteger1 ival;
10938         ffetargetTypeless tless;
10939         ffebad error;
10940
10941         tless = ffebld_cu_val_typeless (*cu);
10942         error = ffetarget_convert_integer1_typeless (&ival, tless);
10943         assert (error == FFEBAD);
10944
10945         item = build_int_2 ((int) ival, 0);
10946       }
10947       break;
10948
10949     default:
10950       assert ("not yet on constant type" == NULL);
10951       /* Fall through. */
10952     case FFEINFO_basictypeANY:
10953       return error_mark_node;
10954     }
10955
10956   TREE_CONSTANT (item) = 1;
10957
10958   return item;
10959 }
10960
10961 #endif
10962
10963 /* Transform expression into constant tree.
10964
10965    If the expression can be transformed into a tree that is constant,
10966    that is done, and the tree returned.  Else NULL_TREE is returned.
10967
10968    That way, a caller can attempt to provide compile-time initialization
10969    of a variable and, if that fails, *then* choose to start a new block
10970    and resort to using temporaries, as appropriate.  */
10971
10972 tree
10973 ffecom_const_expr (ffebld expr)
10974 {
10975   if (! expr)
10976     return integer_zero_node;
10977
10978   if (ffebld_op (expr) == FFEBLD_opANY)
10979     return error_mark_node;
10980
10981   if (ffebld_arity (expr) == 0
10982       && (ffebld_op (expr) != FFEBLD_opSYMTER
10983 #if NEWCOMMON
10984           /* ~~Enable once common/equivalence is handled properly?  */
10985           || ffebld_where (expr) == FFEINFO_whereCOMMON
10986 #endif
10987           || ffebld_where (expr) == FFEINFO_whereGLOBAL
10988           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10989     {
10990       tree t;
10991
10992       t = ffecom_expr (expr);
10993       assert (TREE_CONSTANT (t));
10994       return t;
10995     }
10996
10997   return NULL_TREE;
10998 }
10999
11000 /* Handy way to make a field in a struct/union.  */
11001
11002 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11003 tree
11004 ffecom_decl_field (tree context, tree prevfield,
11005                    const char *name, tree type)
11006 {
11007   tree field;
11008
11009   field = build_decl (FIELD_DECL, get_identifier (name), type);
11010   DECL_CONTEXT (field) = context;
11011   DECL_FRAME_SIZE (field) = 0;
11012   if (prevfield != NULL_TREE)
11013     TREE_CHAIN (prevfield) = field;
11014
11015   return field;
11016 }
11017
11018 #endif
11019
11020 void
11021 ffecom_close_include (FILE *f)
11022 {
11023 #if FFECOM_GCC_INCLUDE
11024   ffecom_close_include_ (f);
11025 #endif
11026 }
11027
11028 int
11029 ffecom_decode_include_option (char *spec)
11030 {
11031 #if FFECOM_GCC_INCLUDE
11032   return ffecom_decode_include_option_ (spec);
11033 #else
11034   return 1;
11035 #endif
11036 }
11037
11038 /* End a compound statement (block).  */
11039
11040 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11041 tree
11042 ffecom_end_compstmt (void)
11043 {
11044   return bison_rule_compstmt_ ();
11045 }
11046 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
11047
11048 /* ffecom_end_transition -- Perform end transition on all symbols
11049
11050    ffecom_end_transition();
11051
11052    Calls ffecom_sym_end_transition for each global and local symbol.  */
11053
11054 void
11055 ffecom_end_transition ()
11056 {
11057 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11058   ffebld item;
11059 #endif
11060
11061   if (ffe_is_ffedebug ())
11062     fprintf (dmpout, "; end_stmt_transition\n");
11063
11064 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11065   ffecom_list_blockdata_ = NULL;
11066   ffecom_list_common_ = NULL;
11067 #endif
11068
11069   ffesymbol_drive (ffecom_sym_end_transition);
11070   if (ffe_is_ffedebug ())
11071     {
11072       ffestorag_report ();
11073 #if FFECOM_targetCURRENT == FFECOM_targetFFE
11074       ffesymbol_report_all ();
11075 #endif
11076     }
11077
11078 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11079   ffecom_start_progunit_ ();
11080
11081   for (item = ffecom_list_blockdata_;
11082        item != NULL;
11083        item = ffebld_trail (item))
11084     {
11085       ffebld callee;
11086       ffesymbol s;
11087       tree dt;
11088       tree t;
11089       tree var;
11090       int yes;
11091       static int number = 0;
11092
11093       callee = ffebld_head (item);
11094       s = ffebld_symter (callee);
11095       t = ffesymbol_hook (s).decl_tree;
11096       if (t == NULL_TREE)
11097         {
11098           s = ffecom_sym_transform_ (s);
11099           t = ffesymbol_hook (s).decl_tree;
11100         }
11101
11102       yes = suspend_momentary ();
11103
11104       dt = build_pointer_type (TREE_TYPE (t));
11105
11106       var = build_decl (VAR_DECL,
11107                         ffecom_get_invented_identifier ("__g77_forceload_%d",
11108                                                         number++),
11109                         dt);
11110       DECL_EXTERNAL (var) = 0;
11111       TREE_STATIC (var) = 1;
11112       TREE_PUBLIC (var) = 0;
11113       DECL_INITIAL (var) = error_mark_node;
11114       TREE_USED (var) = 1;
11115
11116       var = start_decl (var, FALSE);
11117
11118       t = ffecom_1 (ADDR_EXPR, dt, t);
11119
11120       finish_decl (var, t, FALSE);
11121
11122       resume_momentary (yes);
11123     }
11124
11125   /* This handles any COMMON areas that weren't referenced but have, for
11126      example, important initial data.  */
11127
11128   for (item = ffecom_list_common_;
11129        item != NULL;
11130        item = ffebld_trail (item))
11131     ffecom_transform_common_ (ffebld_symter (ffebld_head (item)));
11132
11133   ffecom_list_common_ = NULL;
11134 #endif
11135 }
11136
11137 /* ffecom_exec_transition -- Perform exec transition on all symbols
11138
11139    ffecom_exec_transition();
11140
11141    Calls ffecom_sym_exec_transition for each global and local symbol.
11142    Make sure error updating not inhibited.  */
11143
11144 void
11145 ffecom_exec_transition ()
11146 {
11147   bool inhibited;
11148
11149   if (ffe_is_ffedebug ())
11150     fprintf (dmpout, "; exec_stmt_transition\n");
11151
11152   inhibited = ffebad_inhibit ();
11153   ffebad_set_inhibit (FALSE);
11154
11155   ffesymbol_drive (ffecom_sym_exec_transition); /* Don't retract! */
11156   ffeequiv_exec_transition ();  /* Handle all pending EQUIVALENCEs. */
11157   if (ffe_is_ffedebug ())
11158     {
11159       ffestorag_report ();
11160 #if FFECOM_targetCURRENT == FFECOM_targetFFE
11161       ffesymbol_report_all ();
11162 #endif
11163     }
11164
11165   if (inhibited)
11166     ffebad_set_inhibit (TRUE);
11167 }
11168
11169 /* Handle assignment statement.
11170
11171    Convert dest and source using ffecom_expr, then join them
11172    with an ASSIGN op and pass the whole thing to expand_expr_stmt.  */
11173
11174 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11175 void
11176 ffecom_expand_let_stmt (ffebld dest, ffebld source)
11177 {
11178   tree dest_tree;
11179   tree dest_length;
11180   tree source_tree;
11181   tree expr_tree;
11182
11183   if (ffeinfo_basictype (ffebld_info (dest)) != FFEINFO_basictypeCHARACTER)
11184     {
11185       bool dest_used;
11186       tree assign_temp;
11187
11188       /* This attempts to replicate the test below, but must not be
11189          true when the test below is false.  (Always err on the side
11190          of creating unused temporaries, to avoid ICEs.)  */
11191       if (ffebld_op (dest) != FFEBLD_opSYMTER
11192           || ((dest_tree = ffesymbol_hook (ffebld_symter (dest)).decl_tree)
11193               && (TREE_CODE (dest_tree) != VAR_DECL
11194                   || TREE_ADDRESSABLE (dest_tree))))
11195         {
11196           ffecom_prepare_expr_ (source, dest);
11197           dest_used = TRUE;
11198         }
11199       else
11200         {
11201           ffecom_prepare_expr_ (source, NULL);
11202           dest_used = FALSE;
11203         }
11204
11205       ffecom_prepare_expr_w (NULL_TREE, dest);
11206
11207       /* For COMPLEX assignment like C1=C2, if partial overlap is possible,
11208          create a temporary through which the assignment is to take place,
11209          since MODIFY_EXPR doesn't handle partial overlap properly.  */
11210       if (ffebld_basictype (dest) == FFEINFO_basictypeCOMPLEX
11211           && ffecom_possible_partial_overlap_ (dest, source))
11212         {
11213           assign_temp = ffecom_make_tempvar ("complex_let",
11214                                              ffecom_tree_type
11215                                              [ffebld_basictype (dest)]
11216                                              [ffebld_kindtype (dest)],
11217                                              FFETARGET_charactersizeNONE,
11218                                              -1);
11219         }
11220       else
11221         assign_temp = NULL_TREE;
11222
11223       ffecom_prepare_end ();
11224
11225       dest_tree = ffecom_expr_w (NULL_TREE, dest);
11226       if (dest_tree == error_mark_node)
11227         return;
11228
11229       if ((TREE_CODE (dest_tree) != VAR_DECL)
11230           || TREE_ADDRESSABLE (dest_tree))
11231         source_tree = ffecom_expr_ (source, dest_tree, dest, &dest_used,
11232                                     FALSE, FALSE);
11233       else
11234         {
11235           assert (! dest_used);
11236           dest_used = FALSE;
11237           source_tree = ffecom_expr (source);
11238         }
11239       if (source_tree == error_mark_node)
11240         return;
11241
11242       if (dest_used)
11243         expr_tree = source_tree;
11244       else if (assign_temp)
11245         {
11246 #ifdef MOVE_EXPR
11247           /* The back end understands a conceptual move (evaluate source;
11248              store into dest), so use that, in case it can determine
11249              that it is going to use, say, two registers as temporaries
11250              anyway.  So don't use the temp (and someday avoid generating
11251              it, once this code starts triggering regularly).  */
11252           expr_tree = ffecom_2s (MOVE_EXPR, void_type_node,
11253                                  dest_tree,
11254                                  source_tree);
11255 #else
11256           expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11257                                  assign_temp,
11258                                  source_tree);
11259           expand_expr_stmt (expr_tree);
11260           expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11261                                  dest_tree,
11262                                  assign_temp);
11263 #endif
11264         }
11265       else
11266         expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11267                                dest_tree,
11268                                source_tree);
11269
11270       expand_expr_stmt (expr_tree);
11271       return;
11272     }
11273
11274   ffecom_prepare_let_char_ (ffebld_size_known (dest), source);
11275   ffecom_prepare_expr_w (NULL_TREE, dest);
11276
11277   ffecom_prepare_end ();
11278
11279   ffecom_char_args_ (&dest_tree, &dest_length, dest);
11280   ffecom_let_char_ (dest_tree, dest_length, ffebld_size_known (dest),
11281                     source);
11282 }
11283
11284 #endif
11285 /* ffecom_expr -- Transform expr into gcc tree
11286
11287    tree t;
11288    ffebld expr;  // FFE expression.
11289    tree = ffecom_expr(expr);
11290
11291    Recursive descent on expr while making corresponding tree nodes and
11292    attaching type info and such.  */
11293
11294 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11295 tree
11296 ffecom_expr (ffebld expr)
11297 {
11298   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, FALSE, FALSE);
11299 }
11300
11301 #endif
11302 /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT.  */
11303
11304 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11305 tree
11306 ffecom_expr_assign (ffebld expr)
11307 {
11308   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
11309 }
11310
11311 #endif
11312 /* Like ffecom_expr_rw, but return tree usable for ASSIGN.  */
11313
11314 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11315 tree
11316 ffecom_expr_assign_w (ffebld expr)
11317 {
11318   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
11319 }
11320
11321 #endif
11322 /* Transform expr for use as into read/write tree and stabilize the
11323    reference.  Not for use on CHARACTER expressions.
11324
11325    Recursive descent on expr while making corresponding tree nodes and
11326    attaching type info and such.  */
11327
11328 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11329 tree
11330 ffecom_expr_rw (tree type, ffebld expr)
11331 {
11332   assert (expr != NULL);
11333   /* Different target types not yet supported.  */
11334   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
11335
11336   return stabilize_reference (ffecom_expr (expr));
11337 }
11338
11339 #endif
11340 /* Transform expr for use as into write tree and stabilize the
11341    reference.  Not for use on CHARACTER expressions.
11342
11343    Recursive descent on expr while making corresponding tree nodes and
11344    attaching type info and such.  */
11345
11346 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11347 tree
11348 ffecom_expr_w (tree type, ffebld expr)
11349 {
11350   assert (expr != NULL);
11351   /* Different target types not yet supported.  */
11352   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
11353
11354   return stabilize_reference (ffecom_expr (expr));
11355 }
11356
11357 #endif
11358 /* Do global stuff.  */
11359
11360 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11361 void
11362 ffecom_finish_compile ()
11363 {
11364   assert (ffecom_outer_function_decl_ == NULL_TREE);
11365   assert (current_function_decl == NULL_TREE);
11366
11367   ffeglobal_drive (ffecom_finish_global_);
11368 }
11369
11370 #endif
11371 /* Public entry point for front end to access finish_decl.  */
11372
11373 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11374 void
11375 ffecom_finish_decl (tree decl, tree init, bool is_top_level)
11376 {
11377   assert (!is_top_level);
11378   finish_decl (decl, init, FALSE);
11379 }
11380
11381 #endif
11382 /* Finish a program unit.  */
11383
11384 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11385 void
11386 ffecom_finish_progunit ()
11387 {
11388   ffecom_end_compstmt ();
11389
11390   ffecom_previous_function_decl_ = current_function_decl;
11391   ffecom_which_entrypoint_decl_ = NULL_TREE;
11392
11393   finish_function (0);
11394 }
11395
11396 #endif
11397
11398 /* Wrapper for get_identifier.  pattern is sprintf-like.  */
11399
11400 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11401 tree
11402 ffecom_get_invented_identifier (const char *pattern, ...)
11403 {
11404   tree decl;
11405   char *nam;
11406   va_list ap;
11407
11408   va_start (ap, pattern);
11409   if (vasprintf (&nam, pattern, ap) == 0)
11410     abort ();
11411   va_end (ap);
11412   decl = get_identifier (nam);
11413   free (nam);
11414   IDENTIFIER_INVENTED (decl) = 1;
11415   return decl;
11416 }
11417
11418 ffeinfoBasictype
11419 ffecom_gfrt_basictype (ffecomGfrt gfrt)
11420 {
11421   assert (gfrt < FFECOM_gfrt);
11422
11423   switch (ffecom_gfrt_type_[gfrt])
11424     {
11425     case FFECOM_rttypeVOID_:
11426     case FFECOM_rttypeVOIDSTAR_:
11427       return FFEINFO_basictypeNONE;
11428
11429     case FFECOM_rttypeFTNINT_:
11430       return FFEINFO_basictypeINTEGER;
11431
11432     case FFECOM_rttypeINTEGER_:
11433       return FFEINFO_basictypeINTEGER;
11434
11435     case FFECOM_rttypeLONGINT_:
11436       return FFEINFO_basictypeINTEGER;
11437
11438     case FFECOM_rttypeLOGICAL_:
11439       return FFEINFO_basictypeLOGICAL;
11440
11441     case FFECOM_rttypeREAL_F2C_:
11442     case FFECOM_rttypeREAL_GNU_:
11443       return FFEINFO_basictypeREAL;
11444
11445     case FFECOM_rttypeCOMPLEX_F2C_:
11446     case FFECOM_rttypeCOMPLEX_GNU_:
11447       return FFEINFO_basictypeCOMPLEX;
11448
11449     case FFECOM_rttypeDOUBLE_:
11450     case FFECOM_rttypeDOUBLEREAL_:
11451       return FFEINFO_basictypeREAL;
11452
11453     case FFECOM_rttypeDBLCMPLX_F2C_:
11454     case FFECOM_rttypeDBLCMPLX_GNU_:
11455       return FFEINFO_basictypeCOMPLEX;
11456
11457     case FFECOM_rttypeCHARACTER_:
11458       return FFEINFO_basictypeCHARACTER;
11459
11460     default:
11461       return FFEINFO_basictypeANY;
11462     }
11463 }
11464
11465 ffeinfoKindtype
11466 ffecom_gfrt_kindtype (ffecomGfrt gfrt)
11467 {
11468   assert (gfrt < FFECOM_gfrt);
11469
11470   switch (ffecom_gfrt_type_[gfrt])
11471     {
11472     case FFECOM_rttypeVOID_:
11473     case FFECOM_rttypeVOIDSTAR_:
11474       return FFEINFO_kindtypeNONE;
11475
11476     case FFECOM_rttypeFTNINT_:
11477       return FFEINFO_kindtypeINTEGER1;
11478
11479     case FFECOM_rttypeINTEGER_:
11480       return FFEINFO_kindtypeINTEGER1;
11481
11482     case FFECOM_rttypeLONGINT_:
11483       return FFEINFO_kindtypeINTEGER4;
11484
11485     case FFECOM_rttypeLOGICAL_:
11486       return FFEINFO_kindtypeLOGICAL1;
11487
11488     case FFECOM_rttypeREAL_F2C_:
11489     case FFECOM_rttypeREAL_GNU_:
11490       return FFEINFO_kindtypeREAL1;
11491
11492     case FFECOM_rttypeCOMPLEX_F2C_:
11493     case FFECOM_rttypeCOMPLEX_GNU_:
11494       return FFEINFO_kindtypeREAL1;
11495
11496     case FFECOM_rttypeDOUBLE_:
11497     case FFECOM_rttypeDOUBLEREAL_:
11498       return FFEINFO_kindtypeREAL2;
11499
11500     case FFECOM_rttypeDBLCMPLX_F2C_:
11501     case FFECOM_rttypeDBLCMPLX_GNU_:
11502       return FFEINFO_kindtypeREAL2;
11503
11504     case FFECOM_rttypeCHARACTER_:
11505       return FFEINFO_kindtypeCHARACTER1;
11506
11507     default:
11508       return FFEINFO_kindtypeANY;
11509     }
11510 }
11511
11512 void
11513 ffecom_init_0 ()
11514 {
11515   tree endlink;
11516   int i;
11517   int j;
11518   tree t;
11519   tree field;
11520   ffetype type;
11521   ffetype base_type;
11522   tree double_ftype_double;
11523   tree float_ftype_float;
11524   tree ldouble_ftype_ldouble;
11525   tree ffecom_tree_ptr_to_fun_type_void;
11526
11527   /* This block of code comes from the now-obsolete cktyps.c.  It checks
11528      whether the compiler environment is buggy in known ways, some of which
11529      would, if not explicitly checked here, result in subtle bugs in g77.  */
11530
11531   if (ffe_is_do_internal_checks ())
11532     {
11533       static char names[][12]
11534         =
11535       {"bar", "bletch", "foo", "foobar"};
11536       char *name;
11537       unsigned long ul;
11538       double fl;
11539
11540       name = bsearch ("foo", &names[0], ARRAY_SIZE (names), sizeof (names[0]),
11541                       (int (*)(const void *, const void *)) strcmp);
11542       if (name != (char *) &names[2])
11543         {
11544           assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
11545                   == NULL);
11546           abort ();
11547         }
11548
11549       ul = strtoul ("123456789", NULL, 10);
11550       if (ul != 123456789L)
11551         {
11552           assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\
11553  in proj.h" == NULL);
11554           abort ();
11555         }
11556
11557       fl = atof ("56.789");
11558       if ((fl < 56.788) || (fl > 56.79))
11559         {
11560           assert ("atof not type double, fix your #include <stdio.h>"
11561                   == NULL);
11562           abort ();
11563         }
11564     }
11565
11566 #if FFECOM_GCC_INCLUDE
11567   ffecom_initialize_char_syntax_ ();
11568 #endif
11569
11570   ffecom_outer_function_decl_ = NULL_TREE;
11571   current_function_decl = NULL_TREE;
11572   named_labels = NULL_TREE;
11573   current_binding_level = NULL_BINDING_LEVEL;
11574   free_binding_level = NULL_BINDING_LEVEL;
11575   /* Make the binding_level structure for global names.  */
11576   pushlevel (0);
11577   global_binding_level = current_binding_level;
11578   current_binding_level->prep_state = 2;
11579
11580   build_common_tree_nodes (1);
11581
11582   /* Define `int' and `char' first so that dbx will output them first.  */
11583   pushdecl (build_decl (TYPE_DECL, get_identifier ("int"),
11584                         integer_type_node));
11585   pushdecl (build_decl (TYPE_DECL, get_identifier ("char"),
11586                         char_type_node));
11587   pushdecl (build_decl (TYPE_DECL, get_identifier ("long int"),
11588                         long_integer_type_node));
11589   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"),
11590                         unsigned_type_node));
11591   pushdecl (build_decl (TYPE_DECL, get_identifier ("long unsigned int"),
11592                         long_unsigned_type_node));
11593   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long int"),
11594                         long_long_integer_type_node));
11595   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long unsigned int"),
11596                         long_long_unsigned_type_node));
11597   pushdecl (build_decl (TYPE_DECL, get_identifier ("short int"),
11598                         short_integer_type_node));
11599   pushdecl (build_decl (TYPE_DECL, get_identifier ("short unsigned int"),
11600                         short_unsigned_type_node));
11601
11602   /* Set the sizetype before we make other types.  This *should* be the
11603      first type we create.  */
11604
11605   set_sizetype
11606     (TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE))));
11607   ffecom_typesize_pointer_
11608     = TREE_INT_CST_LOW (TYPE_SIZE (sizetype)) / BITS_PER_UNIT;
11609
11610   build_common_tree_nodes_2 (0);
11611
11612   /* Define both `signed char' and `unsigned char'.  */
11613   pushdecl (build_decl (TYPE_DECL, get_identifier ("signed char"),
11614                         signed_char_type_node));
11615
11616   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"),
11617                         unsigned_char_type_node));
11618
11619   pushdecl (build_decl (TYPE_DECL, get_identifier ("float"),
11620                         float_type_node));
11621   pushdecl (build_decl (TYPE_DECL, get_identifier ("double"),
11622                         double_type_node));
11623   pushdecl (build_decl (TYPE_DECL, get_identifier ("long double"),
11624                         long_double_type_node));
11625
11626   /* For now, override what build_common_tree_nodes has done.  */
11627   complex_integer_type_node = ffecom_make_complex_type_ (integer_type_node);
11628   complex_float_type_node = ffecom_make_complex_type_ (float_type_node);
11629   complex_double_type_node = ffecom_make_complex_type_ (double_type_node);
11630   complex_long_double_type_node
11631     = ffecom_make_complex_type_ (long_double_type_node);
11632
11633   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex int"),
11634                         complex_integer_type_node));
11635   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex float"),
11636                         complex_float_type_node));
11637   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex double"),
11638                         complex_double_type_node));
11639   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex long double"),
11640                         complex_long_double_type_node));
11641
11642   pushdecl (build_decl (TYPE_DECL, get_identifier ("void"),
11643                         void_type_node));
11644   /* We are not going to have real types in C with less than byte alignment,
11645      so we might as well not have any types that claim to have it.  */
11646   TYPE_ALIGN (void_type_node) = BITS_PER_UNIT;
11647
11648   string_type_node = build_pointer_type (char_type_node);
11649
11650   ffecom_tree_fun_type_void
11651     = build_function_type (void_type_node, NULL_TREE);
11652
11653   ffecom_tree_ptr_to_fun_type_void
11654     = build_pointer_type (ffecom_tree_fun_type_void);
11655
11656   endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
11657
11658   float_ftype_float
11659     = build_function_type (float_type_node,
11660                            tree_cons (NULL_TREE, float_type_node, endlink));
11661
11662   double_ftype_double
11663     = build_function_type (double_type_node,
11664                            tree_cons (NULL_TREE, double_type_node, endlink));
11665
11666   ldouble_ftype_ldouble
11667     = build_function_type (long_double_type_node,
11668                            tree_cons (NULL_TREE, long_double_type_node,
11669                                       endlink));
11670
11671   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11672     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11673       {
11674         ffecom_tree_type[i][j] = NULL_TREE;
11675         ffecom_tree_fun_type[i][j] = NULL_TREE;
11676         ffecom_tree_ptr_to_fun_type[i][j] = NULL_TREE;
11677         ffecom_f2c_typecode_[i][j] = -1;
11678       }
11679
11680   /* Set up standard g77 types.  Note that INTEGER and LOGICAL are set
11681      to size FLOAT_TYPE_SIZE because they have to be the same size as
11682      REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
11683      Compiler options and other such stuff that change the ways these
11684      types are set should not affect this particular setup.  */
11685
11686   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1]
11687     = t = make_signed_type (FLOAT_TYPE_SIZE);
11688   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer"),
11689                         t));
11690   type = ffetype_new ();
11691   base_type = type;
11692   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER1,
11693                     type);
11694   ffetype_set_ams (type,
11695                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11696                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11697   ffetype_set_star (base_type,
11698                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11699                     type);
11700   ffetype_set_kind (base_type, 1, type);
11701   ffecom_typesize_integer1_ = ffetype_size (type);
11702   assert (ffetype_size (type) == sizeof (ffetargetInteger1));
11703
11704   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER1]
11705     = t = make_unsigned_type (FLOAT_TYPE_SIZE); /* HOLLERITH means unsigned. */
11706   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned"),
11707                         t));
11708
11709   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER2]
11710     = t = make_signed_type (CHAR_TYPE_SIZE);
11711   pushdecl (build_decl (TYPE_DECL, get_identifier ("byte"),
11712                         t));
11713   type = ffetype_new ();
11714   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER2,
11715                     type);
11716   ffetype_set_ams (type,
11717                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11718                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11719   ffetype_set_star (base_type,
11720                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11721                     type);
11722   ffetype_set_kind (base_type, 3, type);
11723   assert (ffetype_size (type) == sizeof (ffetargetInteger2));
11724
11725   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER2]
11726     = t = make_unsigned_type (CHAR_TYPE_SIZE);
11727   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned byte"),
11728                         t));
11729
11730   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER3]
11731     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11732   pushdecl (build_decl (TYPE_DECL, get_identifier ("word"),
11733                         t));
11734   type = ffetype_new ();
11735   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER3,
11736                     type);
11737   ffetype_set_ams (type,
11738                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11739                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11740   ffetype_set_star (base_type,
11741                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11742                     type);
11743   ffetype_set_kind (base_type, 6, type);
11744   assert (ffetype_size (type) == sizeof (ffetargetInteger3));
11745
11746   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER3]
11747     = t = make_unsigned_type (CHAR_TYPE_SIZE * 2);
11748   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned word"),
11749                         t));
11750
11751   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER4]
11752     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11753   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer4"),
11754                         t));
11755   type = ffetype_new ();
11756   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER4,
11757                     type);
11758   ffetype_set_ams (type,
11759                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11760                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11761   ffetype_set_star (base_type,
11762                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11763                     type);
11764   ffetype_set_kind (base_type, 2, type);
11765   assert (ffetype_size (type) == sizeof (ffetargetInteger4));
11766
11767   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER4]
11768     = t = make_unsigned_type (FLOAT_TYPE_SIZE * 2);
11769   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned4"),
11770                         t));
11771
11772 #if 0
11773   if (ffe_is_do_internal_checks ()
11774       && LONG_TYPE_SIZE != FLOAT_TYPE_SIZE
11775       && LONG_TYPE_SIZE != CHAR_TYPE_SIZE
11776       && LONG_TYPE_SIZE != SHORT_TYPE_SIZE
11777       && LONG_TYPE_SIZE != LONG_LONG_TYPE_SIZE)
11778     {
11779       fprintf (stderr, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n",
11780                LONG_TYPE_SIZE);
11781     }
11782 #endif
11783
11784   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL1]
11785     = t = make_signed_type (FLOAT_TYPE_SIZE);
11786   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical"),
11787                         t));
11788   type = ffetype_new ();
11789   base_type = type;
11790   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL1,
11791                     type);
11792   ffetype_set_ams (type,
11793                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11794                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11795   ffetype_set_star (base_type,
11796                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11797                     type);
11798   ffetype_set_kind (base_type, 1, type);
11799   assert (ffetype_size (type) == sizeof (ffetargetLogical1));
11800
11801   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL2]
11802     = t = make_signed_type (CHAR_TYPE_SIZE);
11803   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical2"),
11804                         t));
11805   type = ffetype_new ();
11806   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL2,
11807                     type);
11808   ffetype_set_ams (type,
11809                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11810                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11811   ffetype_set_star (base_type,
11812                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11813                     type);
11814   ffetype_set_kind (base_type, 3, type);
11815   assert (ffetype_size (type) == sizeof (ffetargetLogical2));
11816
11817   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL3]
11818     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11819   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical3"),
11820                         t));
11821   type = ffetype_new ();
11822   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL3,
11823                     type);
11824   ffetype_set_ams (type,
11825                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11826                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11827   ffetype_set_star (base_type,
11828                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11829                     type);
11830   ffetype_set_kind (base_type, 6, type);
11831   assert (ffetype_size (type) == sizeof (ffetargetLogical3));
11832
11833   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL4]
11834     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11835   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical4"),
11836                         t));
11837   type = ffetype_new ();
11838   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL4,
11839                     type);
11840   ffetype_set_ams (type,
11841                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11842                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11843   ffetype_set_star (base_type,
11844                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11845                     type);
11846   ffetype_set_kind (base_type, 2, type);
11847   assert (ffetype_size (type) == sizeof (ffetargetLogical4));
11848
11849   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11850     = t = make_node (REAL_TYPE);
11851   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE;
11852   pushdecl (build_decl (TYPE_DECL, get_identifier ("real"),
11853                         t));
11854   layout_type (t);
11855   type = ffetype_new ();
11856   base_type = type;
11857   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL1,
11858                     type);
11859   ffetype_set_ams (type,
11860                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11861                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11862   ffetype_set_star (base_type,
11863                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11864                     type);
11865   ffetype_set_kind (base_type, 1, type);
11866   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11867     = FFETARGET_f2cTYREAL;
11868   assert (ffetype_size (type) == sizeof (ffetargetReal1));
11869
11870   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREALDOUBLE]
11871     = t = make_node (REAL_TYPE);
11872   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE * 2;     /* Always twice REAL. */
11873   pushdecl (build_decl (TYPE_DECL, get_identifier ("double precision"),
11874                         t));
11875   layout_type (t);
11876   type = ffetype_new ();
11877   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
11878                     type);
11879   ffetype_set_ams (type,
11880                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11881                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11882   ffetype_set_star (base_type,
11883                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11884                     type);
11885   ffetype_set_kind (base_type, 2, type);
11886   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]
11887     = FFETARGET_f2cTYDREAL;
11888   assert (ffetype_size (type) == sizeof (ffetargetReal2));
11889
11890   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11891     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]);
11892   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex"),
11893                         t));
11894   type = ffetype_new ();
11895   base_type = type;
11896   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL1,
11897                     type);
11898   ffetype_set_ams (type,
11899                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11900                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11901   ffetype_set_star (base_type,
11902                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11903                     type);
11904   ffetype_set_kind (base_type, 1, type);
11905   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11906     = FFETARGET_f2cTYCOMPLEX;
11907   assert (ffetype_size (type) == sizeof (ffetargetComplex1));
11908
11909   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREALDOUBLE]
11910     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]);
11911   pushdecl (build_decl (TYPE_DECL, get_identifier ("double complex"),
11912                         t));
11913   type = ffetype_new ();
11914   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREALDOUBLE,
11915                     type);
11916   ffetype_set_ams (type,
11917                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11918                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11919   ffetype_set_star (base_type,
11920                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11921                     type);
11922   ffetype_set_kind (base_type, 2,
11923                     type);
11924   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL2]
11925     = FFETARGET_f2cTYDCOMPLEX;
11926   assert (ffetype_size (type) == sizeof (ffetargetComplex2));
11927
11928   /* Make function and ptr-to-function types for non-CHARACTER types. */
11929
11930   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11931     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11932       {
11933         if ((t = ffecom_tree_type[i][j]) != NULL_TREE)
11934           {
11935             if (i == FFEINFO_basictypeINTEGER)
11936               {
11937                 /* Figure out the smallest INTEGER type that can hold
11938                    a pointer on this machine. */
11939                 if (GET_MODE_SIZE (TYPE_MODE (t))
11940                     >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
11941                   {
11942                     if ((ffecom_pointer_kind_ == FFEINFO_kindtypeNONE)
11943                         || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type[i][ffecom_pointer_kind_]))
11944                             > GET_MODE_SIZE (TYPE_MODE (t))))
11945                       ffecom_pointer_kind_ = j;
11946                   }
11947               }
11948             else if (i == FFEINFO_basictypeCOMPLEX)
11949               t = void_type_node;
11950             /* For f2c compatibility, REAL functions are really
11951                implemented as DOUBLE PRECISION.  */
11952             else if ((i == FFEINFO_basictypeREAL)
11953                      && (j == FFEINFO_kindtypeREAL1))
11954               t = ffecom_tree_type
11955                 [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2];
11956
11957             t = ffecom_tree_fun_type[i][j] = build_function_type (t,
11958                                                                   NULL_TREE);
11959             ffecom_tree_ptr_to_fun_type[i][j] = build_pointer_type (t);
11960           }
11961       }
11962
11963   /* Set up pointer types.  */
11964
11965   if (ffecom_pointer_kind_ == FFEINFO_basictypeNONE)
11966     fatal ("no INTEGER type can hold a pointer on this configuration");
11967   else if (0 && ffe_is_do_internal_checks ())
11968     fprintf (stderr, "Pointer type kt=%d\n", ffecom_pointer_kind_);
11969   ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER,
11970                                   FFEINFO_kindtypeINTEGERDEFAULT),
11971                     7,
11972                     ffeinfo_type (FFEINFO_basictypeINTEGER,
11973                                   ffecom_pointer_kind_));
11974
11975   if (ffe_is_ugly_assign ())
11976     ffecom_label_kind_ = ffecom_pointer_kind_;  /* Require ASSIGN etc to this. */
11977   else
11978     ffecom_label_kind_ = FFEINFO_kindtypeINTEGERDEFAULT;
11979   if (0 && ffe_is_do_internal_checks ())
11980     fprintf (stderr, "Label type kt=%d\n", ffecom_label_kind_);
11981
11982   ffecom_integer_type_node
11983     = ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1];
11984   ffecom_integer_zero_node = convert (ffecom_integer_type_node,
11985                                       integer_zero_node);
11986   ffecom_integer_one_node = convert (ffecom_integer_type_node,
11987                                      integer_one_node);
11988
11989   /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
11990      Turns out that by TYLONG, runtime/libI77/lio.h really means
11991      "whatever size an ftnint is".  For consistency and sanity,
11992      com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
11993      all are INTEGER, which we also make out of whatever back-end
11994      integer type is FLOAT_TYPE_SIZE bits wide.  This change, from
11995      LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
11996      accommodate machines like the Alpha.  Note that this suggests
11997      f2c and libf2c are missing a distinction perhaps needed on
11998      some machines between "int" and "long int".  -- burley 0.5.5 950215 */
11999
12000   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, FLOAT_TYPE_SIZE,
12001                             FFETARGET_f2cTYLONG);
12002   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, SHORT_TYPE_SIZE,
12003                             FFETARGET_f2cTYSHORT);
12004   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, CHAR_TYPE_SIZE,
12005                             FFETARGET_f2cTYINT1);
12006   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, LONG_LONG_TYPE_SIZE,
12007                             FFETARGET_f2cTYQUAD);
12008   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, FLOAT_TYPE_SIZE,
12009                             FFETARGET_f2cTYLOGICAL);
12010   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, SHORT_TYPE_SIZE,
12011                             FFETARGET_f2cTYLOGICAL2);
12012   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, CHAR_TYPE_SIZE,
12013                             FFETARGET_f2cTYLOGICAL1);
12014   /* ~~~Not really such a type in libf2c, e.g. I/O support?  */
12015   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, LONG_LONG_TYPE_SIZE,
12016                             FFETARGET_f2cTYQUAD);
12017
12018   /* CHARACTER stuff is all special-cased, so it is not handled in the above
12019      loop.  CHARACTER items are built as arrays of unsigned char.  */
12020
12021   ffecom_tree_type[FFEINFO_basictypeCHARACTER]
12022     [FFEINFO_kindtypeCHARACTER1] = t = char_type_node;
12023   type = ffetype_new ();
12024   base_type = type;
12025   ffeinfo_set_type (FFEINFO_basictypeCHARACTER,
12026                     FFEINFO_kindtypeCHARACTER1,
12027                     type);
12028   ffetype_set_ams (type,
12029                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
12030                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
12031   ffetype_set_kind (base_type, 1, type);
12032   assert (ffetype_size (type)
12033           == sizeof (((ffetargetCharacter1) { 0, NULL }).text[0]));
12034
12035   ffecom_tree_fun_type[FFEINFO_basictypeCHARACTER]
12036     [FFEINFO_kindtypeCHARACTER1] = ffecom_tree_fun_type_void;
12037   ffecom_tree_ptr_to_fun_type[FFEINFO_basictypeCHARACTER]
12038     [FFEINFO_kindtypeCHARACTER1]
12039     = ffecom_tree_ptr_to_fun_type_void;
12040   ffecom_f2c_typecode_[FFEINFO_basictypeCHARACTER][FFEINFO_kindtypeCHARACTER1]
12041     = FFETARGET_f2cTYCHAR;
12042
12043   ffecom_f2c_typecode_[FFEINFO_basictypeANY][FFEINFO_kindtypeANY]
12044     = 0;
12045
12046   /* Make multi-return-value type and fields. */
12047
12048   ffecom_multi_type_node_ = make_node (UNION_TYPE);
12049
12050   field = NULL_TREE;
12051
12052   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
12053     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
12054       {
12055         char name[30];
12056
12057         if (ffecom_tree_type[i][j] == NULL_TREE)
12058           continue;             /* Not supported. */
12059         sprintf (&name[0], "bt_%s_kt_%s",
12060                  ffeinfo_basictype_string ((ffeinfoBasictype) i),
12061                  ffeinfo_kindtype_string ((ffeinfoKindtype) j));
12062         ffecom_multi_fields_[i][j] = build_decl (FIELD_DECL,
12063                                                  get_identifier (name),
12064                                                  ffecom_tree_type[i][j]);
12065         DECL_CONTEXT (ffecom_multi_fields_[i][j])
12066           = ffecom_multi_type_node_;
12067         DECL_FRAME_SIZE (ffecom_multi_fields_[i][j]) = 0;
12068         TREE_CHAIN (ffecom_multi_fields_[i][j]) = field;
12069         field = ffecom_multi_fields_[i][j];
12070       }
12071
12072   TYPE_FIELDS (ffecom_multi_type_node_) = field;
12073   layout_type (ffecom_multi_type_node_);
12074
12075   /* Subroutines usually return integer because they might have alternate
12076      returns. */
12077
12078   ffecom_tree_subr_type
12079     = build_function_type (integer_type_node, NULL_TREE);
12080   ffecom_tree_ptr_to_subr_type
12081     = build_pointer_type (ffecom_tree_subr_type);
12082   ffecom_tree_blockdata_type
12083     = build_function_type (void_type_node, NULL_TREE);
12084
12085   builtin_function ("__builtin_sqrtf", float_ftype_float,
12086                     BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrtf");
12087   builtin_function ("__builtin_fsqrt", double_ftype_double,
12088                     BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrt");
12089   builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble,
12090                     BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrtl");
12091   builtin_function ("__builtin_sinf", float_ftype_float,
12092                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sinf");
12093   builtin_function ("__builtin_sin", double_ftype_double,
12094                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sin");
12095   builtin_function ("__builtin_sinl", ldouble_ftype_ldouble,
12096                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sinl");
12097   builtin_function ("__builtin_cosf", float_ftype_float,
12098                     BUILT_IN_COS, BUILT_IN_NORMAL, "cosf");
12099   builtin_function ("__builtin_cos", double_ftype_double,
12100                     BUILT_IN_COS, BUILT_IN_NORMAL, "cos");
12101   builtin_function ("__builtin_cosl", ldouble_ftype_ldouble,
12102                     BUILT_IN_COS, BUILT_IN_NORMAL, "cosl");
12103
12104 #if BUILT_FOR_270
12105   pedantic_lvalues = FALSE;
12106 #endif
12107
12108   ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node,
12109                          FFECOM_f2cINTEGER,
12110                          "integer");
12111   ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node,
12112                          FFECOM_f2cADDRESS,
12113                          "address");
12114   ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node,
12115                          FFECOM_f2cREAL,
12116                          "real");
12117   ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node,
12118                          FFECOM_f2cDOUBLEREAL,
12119                          "doublereal");
12120   ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node,
12121                          FFECOM_f2cCOMPLEX,
12122                          "complex");
12123   ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node,
12124                          FFECOM_f2cDOUBLECOMPLEX,
12125                          "doublecomplex");
12126   ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node,
12127                          FFECOM_f2cLONGINT,
12128                          "longint");
12129   ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node,
12130                          FFECOM_f2cLOGICAL,
12131                          "logical");
12132   ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node,
12133                          FFECOM_f2cFLAG,
12134                          "flag");
12135   ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node,
12136                          FFECOM_f2cFTNLEN,
12137                          "ftnlen");
12138   ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node,
12139                          FFECOM_f2cFTNINT,
12140                          "ftnint");
12141
12142   ffecom_f2c_ftnlen_zero_node
12143     = convert (ffecom_f2c_ftnlen_type_node, integer_zero_node);
12144
12145   ffecom_f2c_ftnlen_one_node
12146     = convert (ffecom_f2c_ftnlen_type_node, integer_one_node);
12147
12148   ffecom_f2c_ftnlen_two_node = build_int_2 (2, 0);
12149   TREE_TYPE (ffecom_f2c_ftnlen_two_node) = ffecom_integer_type_node;
12150
12151   ffecom_f2c_ptr_to_ftnlen_type_node
12152     = build_pointer_type (ffecom_f2c_ftnlen_type_node);
12153
12154   ffecom_f2c_ptr_to_ftnint_type_node
12155     = build_pointer_type (ffecom_f2c_ftnint_type_node);
12156
12157   ffecom_f2c_ptr_to_integer_type_node
12158     = build_pointer_type (ffecom_f2c_integer_type_node);
12159
12160   ffecom_f2c_ptr_to_real_type_node
12161     = build_pointer_type (ffecom_f2c_real_type_node);
12162
12163   ffecom_float_zero_ = build_real (float_type_node, dconst0);
12164   ffecom_double_zero_ = build_real (double_type_node, dconst0);
12165   {
12166     REAL_VALUE_TYPE point_5;
12167
12168 #ifdef REAL_ARITHMETIC
12169     REAL_ARITHMETIC (point_5, RDIV_EXPR, dconst1, dconst2);
12170 #else
12171     point_5 = .5;
12172 #endif
12173     ffecom_float_half_ = build_real (float_type_node, point_5);
12174     ffecom_double_half_ = build_real (double_type_node, point_5);
12175   }
12176
12177   /* Do "extern int xargc;".  */
12178
12179   ffecom_tree_xargc_ = build_decl (VAR_DECL,
12180                                    get_identifier ("f__xargc"),
12181                                    integer_type_node);
12182   DECL_EXTERNAL (ffecom_tree_xargc_) = 1;
12183   TREE_STATIC (ffecom_tree_xargc_) = 1;
12184   TREE_PUBLIC (ffecom_tree_xargc_) = 1;
12185   ffecom_tree_xargc_ = start_decl (ffecom_tree_xargc_, FALSE);
12186   finish_decl (ffecom_tree_xargc_, NULL_TREE, FALSE);
12187
12188 #if 0   /* This is being fixed, and seems to be working now. */
12189   if ((FLOAT_TYPE_SIZE != 32)
12190       || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))) != 32))
12191     {
12192       warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,",
12193                (int) FLOAT_TYPE_SIZE);
12194       warning ("and pointers are %d bits wide, but g77 doesn't yet work",
12195           (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))));
12196       warning ("properly unless they all are 32 bits wide.");
12197       warning ("Please keep this in mind before you report bugs.  g77 should");
12198       warning ("support non-32-bit machines better as of version 0.6.");
12199     }
12200 #endif
12201
12202 #if 0   /* Code in ste.c that would crash has been commented out. */
12203   if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
12204       < TYPE_PRECISION (string_type_node))
12205     /* I/O will probably crash.  */
12206     warning ("configuration: char * holds %d bits, but ftnlen only %d",
12207              TYPE_PRECISION (string_type_node),
12208              TYPE_PRECISION (ffecom_f2c_ftnlen_type_node));
12209 #endif
12210
12211 #if 0   /* ASSIGN-related stuff has been changed to accommodate this. */
12212   if (TYPE_PRECISION (ffecom_integer_type_node)
12213       < TYPE_PRECISION (string_type_node))
12214     /* ASSIGN 10 TO I will crash.  */
12215     warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
12216  ASSIGN statement might fail",
12217              TYPE_PRECISION (string_type_node),
12218              TYPE_PRECISION (ffecom_integer_type_node));
12219 #endif
12220 }
12221
12222 #endif
12223 /* ffecom_init_2 -- Initialize
12224
12225    ffecom_init_2();  */
12226
12227 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12228 void
12229 ffecom_init_2 ()
12230 {
12231   assert (ffecom_outer_function_decl_ == NULL_TREE);
12232   assert (current_function_decl == NULL_TREE);
12233   assert (ffecom_which_entrypoint_decl_ == NULL_TREE);
12234
12235   ffecom_master_arglist_ = NULL;
12236   ++ffecom_num_fns_;
12237   ffecom_primary_entry_ = NULL;
12238   ffecom_is_altreturning_ = FALSE;
12239   ffecom_func_result_ = NULL_TREE;
12240   ffecom_multi_retval_ = NULL_TREE;
12241 }
12242
12243 #endif
12244 /* ffecom_list_expr -- Transform list of exprs into gcc tree
12245
12246    tree t;
12247    ffebld expr;  // FFE opITEM list.
12248    tree = ffecom_list_expr(expr);
12249
12250    List of actual args is transformed into corresponding gcc backend list.  */
12251
12252 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12253 tree
12254 ffecom_list_expr (ffebld expr)
12255 {
12256   tree list;
12257   tree *plist = &list;
12258   tree trail = NULL_TREE;       /* Append char length args here. */
12259   tree *ptrail = &trail;
12260   tree length;
12261
12262   while (expr != NULL)
12263     {
12264       tree texpr = ffecom_arg_expr (ffebld_head (expr), &length);
12265
12266       if (texpr == error_mark_node)
12267         return error_mark_node;
12268
12269       *plist = build_tree_list (NULL_TREE, texpr);
12270       plist = &TREE_CHAIN (*plist);
12271       expr = ffebld_trail (expr);
12272       if (length != NULL_TREE)
12273         {
12274           *ptrail = build_tree_list (NULL_TREE, length);
12275           ptrail = &TREE_CHAIN (*ptrail);
12276         }
12277     }
12278
12279   *plist = trail;
12280
12281   return list;
12282 }
12283
12284 #endif
12285 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
12286
12287    tree t;
12288    ffebld expr;  // FFE opITEM list.
12289    tree = ffecom_list_ptr_to_expr(expr);
12290
12291    List of actual args is transformed into corresponding gcc backend list for
12292    use in calling an external procedure (vs. a statement function).  */
12293
12294 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12295 tree
12296 ffecom_list_ptr_to_expr (ffebld expr)
12297 {
12298   tree list;
12299   tree *plist = &list;
12300   tree trail = NULL_TREE;       /* Append char length args here. */
12301   tree *ptrail = &trail;
12302   tree length;
12303
12304   while (expr != NULL)
12305     {
12306       tree texpr = ffecom_arg_ptr_to_expr (ffebld_head (expr), &length);
12307
12308       if (texpr == error_mark_node)
12309         return error_mark_node;
12310
12311       *plist = build_tree_list (NULL_TREE, texpr);
12312       plist = &TREE_CHAIN (*plist);
12313       expr = ffebld_trail (expr);
12314       if (length != NULL_TREE)
12315         {
12316           *ptrail = build_tree_list (NULL_TREE, length);
12317           ptrail = &TREE_CHAIN (*ptrail);
12318         }
12319     }
12320
12321   *plist = trail;
12322
12323   return list;
12324 }
12325
12326 #endif
12327 /* Obtain gcc's LABEL_DECL tree for label.  */
12328
12329 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12330 tree
12331 ffecom_lookup_label (ffelab label)
12332 {
12333   tree glabel;
12334
12335   if (ffelab_hook (label) == NULL_TREE)
12336     {
12337       char labelname[16];
12338
12339       switch (ffelab_type (label))
12340         {
12341         case FFELAB_typeLOOPEND:
12342         case FFELAB_typeNOTLOOP:
12343         case FFELAB_typeENDIF:
12344           sprintf (labelname, "%" ffelabValue_f "u", ffelab_value (label));
12345           glabel = build_decl (LABEL_DECL, get_identifier (labelname),
12346                                void_type_node);
12347           DECL_CONTEXT (glabel) = current_function_decl;
12348           DECL_MODE (glabel) = VOIDmode;
12349           break;
12350
12351         case FFELAB_typeFORMAT:
12352           glabel = build_decl (VAR_DECL,
12353                                ffecom_get_invented_identifier
12354                                ("__g77_format_%d", (int) ffelab_value (label)),
12355                                build_type_variant (build_array_type
12356                                                    (char_type_node,
12357                                                     NULL_TREE),
12358                                                    1, 0));
12359           TREE_CONSTANT (glabel) = 1;
12360           TREE_STATIC (glabel) = 1;
12361           DECL_CONTEXT (glabel) = 0;
12362           DECL_INITIAL (glabel) = NULL;
12363           make_decl_rtl (glabel, NULL, 0);
12364           expand_decl (glabel);
12365
12366           ffecom_save_tree_forever (glabel);
12367
12368           break;
12369
12370         case FFELAB_typeANY:
12371           glabel = error_mark_node;
12372           break;
12373
12374         default:
12375           assert ("bad label type" == NULL);
12376           glabel = NULL;
12377           break;
12378         }
12379       ffelab_set_hook (label, glabel);
12380     }
12381   else
12382     {
12383       glabel = ffelab_hook (label);
12384     }
12385
12386   return glabel;
12387 }
12388
12389 #endif
12390 /* Stabilizes the arguments.  Don't use this if the lhs and rhs come from
12391    a single source specification (as in the fourth argument of MVBITS).
12392    If the type is NULL_TREE, the type of lhs is used to make the type of
12393    the MODIFY_EXPR.  */
12394
12395 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12396 tree
12397 ffecom_modify (tree newtype, tree lhs,
12398                tree rhs)
12399 {
12400   if (lhs == error_mark_node || rhs == error_mark_node)
12401     return error_mark_node;
12402
12403   if (newtype == NULL_TREE)
12404     newtype = TREE_TYPE (lhs);
12405
12406   if (TREE_SIDE_EFFECTS (lhs))
12407     lhs = stabilize_reference (lhs);
12408
12409   return ffecom_2s (MODIFY_EXPR, newtype, lhs, rhs);
12410 }
12411
12412 #endif
12413
12414 /* Register source file name.  */
12415
12416 void
12417 ffecom_file (const char *name)
12418 {
12419 #if FFECOM_GCC_INCLUDE
12420   ffecom_file_ (name);
12421 #endif
12422 }
12423
12424 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
12425
12426    ffestorag st;
12427    ffecom_notify_init_storage(st);
12428
12429    Gets called when all possible units in an aggregate storage area (a LOCAL
12430    with equivalences or a COMMON) have been initialized.  The initialization
12431    info either is in ffestorag_init or, if that is NULL,
12432    ffestorag_accretion:
12433
12434    ffestorag_init may contain an opCONTER or opARRTER.  opCONTER may occur
12435    even for an array if the array is one element in length!
12436
12437    ffestorag_accretion will contain an opACCTER.  It is much like an
12438    opARRTER except it has an ffebit object in it instead of just a size.
12439    The back end can use the info in the ffebit object, if it wants, to
12440    reduce the amount of actual initialization, but in any case it should
12441    kill the ffebit object when done.  Also, set accretion to NULL but
12442    init to a non-NULL value.
12443
12444    After performing initialization, DO NOT set init to NULL, because that'll
12445    tell the front end it is ok for more initialization to happen.  Instead,
12446    set init to an opANY expression or some such thing that you can use to
12447    tell that you've already initialized the object.
12448
12449    27-Oct-91  JCB  1.1
12450       Support two-pass FFE.  */
12451
12452 void
12453 ffecom_notify_init_storage (ffestorag st)
12454 {
12455   ffebld init;                  /* The initialization expression. */
12456 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12457   ffetargetOffset size;         /* The size of the entity. */
12458   ffetargetAlign pad;           /* Its initial padding. */
12459 #endif
12460
12461   if (ffestorag_init (st) == NULL)
12462     {
12463       init = ffestorag_accretion (st);
12464       assert (init != NULL);
12465       ffestorag_set_accretion (st, NULL);
12466       ffestorag_set_accretes (st, 0);
12467
12468 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12469       /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12470       size = ffebld_accter_size (init);
12471       pad = ffebld_accter_pad (init);
12472       ffebit_kill (ffebld_accter_bits (init));
12473       ffebld_set_op (init, FFEBLD_opARRTER);
12474       ffebld_set_arrter (init, ffebld_accter (init));
12475       ffebld_arrter_set_size (init, size);
12476       ffebld_arrter_set_pad (init, size);
12477 #endif
12478
12479 #if FFECOM_TWOPASS
12480       ffestorag_set_init (st, init);
12481 #endif
12482     }
12483 #if FFECOM_ONEPASS
12484   else
12485     init = ffestorag_init (st);
12486 #endif
12487
12488 #if FFECOM_ONEPASS              /* Process the inits, wipe 'em out. */
12489   ffestorag_set_init (st, ffebld_new_any ());
12490
12491   if (ffebld_op (init) == FFEBLD_opANY)
12492     return;                     /* Oh, we already did this! */
12493
12494 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12495   {
12496     ffesymbol s;
12497
12498     if (ffestorag_symbol (st) != NULL)
12499       s = ffestorag_symbol (st);
12500     else
12501       s = ffestorag_typesymbol (st);
12502
12503     fprintf (dmpout, "= initialize_storage \"%s\" ",
12504              (s != NULL) ? ffesymbol_text (s) : "(unnamed)");
12505     ffebld_dump (init);
12506     fputc ('\n', dmpout);
12507   }
12508 #endif
12509
12510 #endif /* if FFECOM_ONEPASS */
12511 }
12512
12513 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12514
12515    ffesymbol s;
12516    ffecom_notify_init_symbol(s);
12517
12518    Gets called when all possible units in a symbol (not placed in COMMON
12519    or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12520    have been initialized.  The initialization info either is in
12521    ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12522
12523    ffesymbol_init may contain an opCONTER or opARRTER.  opCONTER may occur
12524    even for an array if the array is one element in length!
12525
12526    ffesymbol_accretion will contain an opACCTER.  It is much like an
12527    opARRTER except it has an ffebit object in it instead of just a size.
12528    The back end can use the info in the ffebit object, if it wants, to
12529    reduce the amount of actual initialization, but in any case it should
12530    kill the ffebit object when done.  Also, set accretion to NULL but
12531    init to a non-NULL value.
12532
12533    After performing initialization, DO NOT set init to NULL, because that'll
12534    tell the front end it is ok for more initialization to happen.  Instead,
12535    set init to an opANY expression or some such thing that you can use to
12536    tell that you've already initialized the object.
12537
12538    27-Oct-91  JCB  1.1
12539       Support two-pass FFE.  */
12540
12541 void
12542 ffecom_notify_init_symbol (ffesymbol s)
12543 {
12544   ffebld init;                  /* The initialization expression. */
12545 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12546   ffetargetOffset size;         /* The size of the entity. */
12547   ffetargetAlign pad;           /* Its initial padding. */
12548 #endif
12549
12550   if (ffesymbol_storage (s) == NULL)
12551     return;                     /* Do nothing until COMMON/EQUIVALENCE
12552                                    possibilities checked. */
12553
12554   if ((ffesymbol_init (s) == NULL)
12555       && ((init = ffesymbol_accretion (s)) != NULL))
12556     {
12557       ffesymbol_set_accretion (s, NULL);
12558       ffesymbol_set_accretes (s, 0);
12559
12560 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12561       /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12562       size = ffebld_accter_size (init);
12563       pad = ffebld_accter_pad (init);
12564       ffebit_kill (ffebld_accter_bits (init));
12565       ffebld_set_op (init, FFEBLD_opARRTER);
12566       ffebld_set_arrter (init, ffebld_accter (init));
12567       ffebld_arrter_set_size (init, size);
12568       ffebld_arrter_set_pad (init, size);
12569 #endif
12570
12571 #if FFECOM_TWOPASS
12572       ffesymbol_set_init (s, init);
12573 #endif
12574     }
12575 #if FFECOM_ONEPASS
12576   else
12577     init = ffesymbol_init (s);
12578 #endif
12579
12580 #if FFECOM_ONEPASS
12581   ffesymbol_set_init (s, ffebld_new_any ());
12582
12583   if (ffebld_op (init) == FFEBLD_opANY)
12584     return;                     /* Oh, we already did this! */
12585
12586 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12587   fprintf (dmpout, "= initialize_symbol \"%s\" ", ffesymbol_text (s));
12588   ffebld_dump (init);
12589   fputc ('\n', dmpout);
12590 #endif
12591
12592 #endif /* if FFECOM_ONEPASS */
12593 }
12594
12595 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12596
12597    ffesymbol s;
12598    ffecom_notify_primary_entry(s);
12599
12600    Gets called when implicit or explicit PROGRAM statement seen or when
12601    FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12602    global symbol that serves as the entry point.  */
12603
12604 void
12605 ffecom_notify_primary_entry (ffesymbol s)
12606 {
12607   ffecom_primary_entry_ = s;
12608   ffecom_primary_entry_kind_ = ffesymbol_kind (s);
12609
12610   if ((ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
12611       || (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE))
12612     ffecom_primary_entry_is_proc_ = TRUE;
12613   else
12614     ffecom_primary_entry_is_proc_ = FALSE;
12615
12616   if (!ffe_is_silent ())
12617     {
12618       if (ffecom_primary_entry_kind_ == FFEINFO_kindPROGRAM)
12619         fprintf (stderr, "%s:\n", ffesymbol_text (s));
12620       else
12621         fprintf (stderr, "  %s:\n", ffesymbol_text (s));
12622     }
12623
12624 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12625   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
12626     {
12627       ffebld list;
12628       ffebld arg;
12629
12630       for (list = ffesymbol_dummyargs (s);
12631            list != NULL;
12632            list = ffebld_trail (list))
12633         {
12634           arg = ffebld_head (list);
12635           if (ffebld_op (arg) == FFEBLD_opSTAR)
12636             {
12637               ffecom_is_altreturning_ = TRUE;
12638               break;
12639             }
12640         }
12641     }
12642 #endif
12643 }
12644
12645 FILE *
12646 ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c)
12647 {
12648 #if FFECOM_GCC_INCLUDE
12649   return ffecom_open_include_ (name, l, c);
12650 #else
12651   return fopen (name, "r");
12652 #endif
12653 }
12654
12655 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
12656
12657    tree t;
12658    ffebld expr;  // FFE expression.
12659    tree = ffecom_ptr_to_expr(expr);
12660
12661    Like ffecom_expr, but sticks address-of in front of most things.  */
12662
12663 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12664 tree
12665 ffecom_ptr_to_expr (ffebld expr)
12666 {
12667   tree item;
12668   ffeinfoBasictype bt;
12669   ffeinfoKindtype kt;
12670   ffesymbol s;
12671
12672   assert (expr != NULL);
12673
12674   switch (ffebld_op (expr))
12675     {
12676     case FFEBLD_opSYMTER:
12677       s = ffebld_symter (expr);
12678       if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
12679         {
12680           ffecomGfrt ix;
12681
12682           ix = ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr));
12683           assert (ix != FFECOM_gfrt);
12684           if ((item = ffecom_gfrt_[ix]) == NULL_TREE)
12685             {
12686               ffecom_make_gfrt_ (ix);
12687               item = ffecom_gfrt_[ix];
12688             }
12689         }
12690       else
12691         {
12692           item = ffesymbol_hook (s).decl_tree;
12693           if (item == NULL_TREE)
12694             {
12695               s = ffecom_sym_transform_ (s);
12696               item = ffesymbol_hook (s).decl_tree;
12697             }
12698         }
12699       assert (item != NULL);
12700       if (item == error_mark_node)
12701         return item;
12702       if (!ffesymbol_hook (s).addr)
12703         item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12704                          item);
12705       return item;
12706
12707     case FFEBLD_opARRAYREF:
12708       return ffecom_arrayref_ (NULL_TREE, expr, 1);
12709
12710     case FFEBLD_opCONTER:
12711
12712       bt = ffeinfo_basictype (ffebld_info (expr));
12713       kt = ffeinfo_kindtype (ffebld_info (expr));
12714
12715       item = ffecom_constantunion (&ffebld_constant_union
12716                                    (ffebld_conter (expr)), bt, kt,
12717                                    ffecom_tree_type[bt][kt]);
12718       if (item == error_mark_node)
12719         return error_mark_node;
12720       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12721                        item);
12722       return item;
12723
12724     case FFEBLD_opANY:
12725       return error_mark_node;
12726
12727     default:
12728       bt = ffeinfo_basictype (ffebld_info (expr));
12729       kt = ffeinfo_kindtype (ffebld_info (expr));
12730
12731       item = ffecom_expr (expr);
12732       if (item == error_mark_node)
12733         return error_mark_node;
12734
12735       /* The back end currently optimizes a bit too zealously for us, in that
12736          we fail JCB001 if the following block of code is omitted.  It checks
12737          to see if the transformed expression is a symbol or array reference,
12738          and encloses it in a SAVE_EXPR if that is the case.  */
12739
12740       STRIP_NOPS (item);
12741       if ((TREE_CODE (item) == VAR_DECL)
12742           || (TREE_CODE (item) == PARM_DECL)
12743           || (TREE_CODE (item) == RESULT_DECL)
12744           || (TREE_CODE (item) == INDIRECT_REF)
12745           || (TREE_CODE (item) == ARRAY_REF)
12746           || (TREE_CODE (item) == COMPONENT_REF)
12747 #ifdef OFFSET_REF
12748           || (TREE_CODE (item) == OFFSET_REF)
12749 #endif
12750           || (TREE_CODE (item) == BUFFER_REF)
12751           || (TREE_CODE (item) == REALPART_EXPR)
12752           || (TREE_CODE (item) == IMAGPART_EXPR))
12753         {
12754           item = ffecom_save_tree (item);
12755         }
12756
12757       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12758                        item);
12759       return item;
12760     }
12761
12762   assert ("fall-through error" == NULL);
12763   return error_mark_node;
12764 }
12765
12766 #endif
12767 /* Obtain a temp var with given data type.
12768
12769    size is FFETARGET_charactersizeNONE for a non-CHARACTER type
12770    or >= 0 for a CHARACTER type.
12771
12772    elements is -1 for a scalar or > 0 for an array of type.  */
12773
12774 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12775 tree
12776 ffecom_make_tempvar (const char *commentary, tree type,
12777                      ffetargetCharacterSize size, int elements)
12778 {
12779   int yes;
12780   tree t;
12781   static int mynumber;
12782
12783   assert (current_binding_level->prep_state < 2);
12784
12785   if (type == error_mark_node)
12786     return error_mark_node;
12787
12788   yes = suspend_momentary ();
12789
12790   if (size != FFETARGET_charactersizeNONE)
12791     type = build_array_type (type,
12792                              build_range_type (ffecom_f2c_ftnlen_type_node,
12793                                                ffecom_f2c_ftnlen_one_node,
12794                                                build_int_2 (size, 0)));
12795   if (elements != -1)
12796     type = build_array_type (type,
12797                              build_range_type (integer_type_node,
12798                                                integer_zero_node,
12799                                                build_int_2 (elements - 1,
12800                                                             0)));
12801   t = build_decl (VAR_DECL,
12802                   ffecom_get_invented_identifier ("__g77_%s_%d",
12803                                                   commentary,
12804                                                   mynumber++),
12805                   type);
12806
12807   t = start_decl (t, FALSE);
12808   finish_decl (t, NULL_TREE, FALSE);
12809
12810   resume_momentary (yes);
12811
12812   return t;
12813 }
12814 #endif
12815
12816 /* Prepare argument pointer to expression.
12817
12818    Like ffecom_prepare_expr, except for expressions to be evaluated
12819    via ffecom_arg_ptr_to_expr.  */
12820
12821 void
12822 ffecom_prepare_arg_ptr_to_expr (ffebld expr)
12823 {
12824   /* ~~For now, it seems to be the same thing.  */
12825   ffecom_prepare_expr (expr);
12826   return;
12827 }
12828
12829 /* End of preparations.  */
12830
12831 bool
12832 ffecom_prepare_end (void)
12833 {
12834   int prep_state = current_binding_level->prep_state;
12835
12836   assert (prep_state < 2);
12837   current_binding_level->prep_state = 2;
12838
12839   return (prep_state == 1) ? TRUE : FALSE;
12840 }
12841
12842 /* Prepare expression.
12843
12844    This is called before any code is generated for the current block.
12845    It scans the expression, declares any temporaries that might be needed
12846    during evaluation of the expression, and stores those temporaries in
12847    the appropriate "hook" fields of the expression.  `dest', if not NULL,
12848    specifies the destination that ffecom_expr_ will see, in case that
12849    helps avoid generating unused temporaries.
12850
12851    ~~Improve to avoid allocating unused temporaries by taking `dest'
12852    into account vis-a-vis aliasing requirements of complex/character
12853    functions.  */
12854
12855 void
12856 ffecom_prepare_expr_ (ffebld expr, ffebld dest UNUSED)
12857 {
12858   ffeinfoBasictype bt;
12859   ffeinfoKindtype kt;
12860   ffetargetCharacterSize sz;
12861   tree tempvar = NULL_TREE;
12862
12863   assert (current_binding_level->prep_state < 2);
12864
12865   if (! expr)
12866     return;
12867
12868   bt = ffeinfo_basictype (ffebld_info (expr));
12869   kt = ffeinfo_kindtype (ffebld_info (expr));
12870   sz = ffeinfo_size (ffebld_info (expr));
12871
12872   /* Generate whatever temporaries are needed to represent the result
12873      of the expression.  */
12874
12875   if (bt == FFEINFO_basictypeCHARACTER)
12876     {
12877       while (ffebld_op (expr) == FFEBLD_opPAREN)
12878         expr = ffebld_left (expr);
12879     }
12880
12881   switch (ffebld_op (expr))
12882     {
12883     default:
12884       /* Don't make temps for SYMTER, CONTER, etc.  */
12885       if (ffebld_arity (expr) == 0)
12886         break;
12887
12888       switch (bt)
12889         {
12890         case FFEINFO_basictypeCOMPLEX:
12891           if (ffebld_op (expr) == FFEBLD_opFUNCREF)
12892             {
12893               ffesymbol s;
12894
12895               if (ffebld_op (ffebld_left (expr)) != FFEBLD_opSYMTER)
12896                 break;
12897
12898               s = ffebld_symter (ffebld_left (expr));
12899               if (ffesymbol_where (s) == FFEINFO_whereCONSTANT
12900                   || (ffesymbol_where (s) != FFEINFO_whereINTRINSIC
12901                       && ! ffesymbol_is_f2c (s))
12902                   || (ffesymbol_where (s) == FFEINFO_whereINTRINSIC
12903                       && ! ffe_is_f2c_library ()))
12904                 break;
12905             }
12906           else if (ffebld_op (expr) == FFEBLD_opPOWER)
12907             {
12908               /* Requires special treatment.  There's no POW_CC function
12909                  in libg2c, so POW_ZZ is used, which means we always
12910                  need a double-complex temp, not a single-complex.  */
12911               kt = FFEINFO_kindtypeREAL2;
12912             }
12913           else if (ffebld_op (expr) != FFEBLD_opDIVIDE)
12914             /* The other ops don't need temps for complex operands.  */
12915             break;
12916
12917           /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
12918              REAL(C).  See 19990325-0.f, routine `check', for cases.  */
12919           tempvar = ffecom_make_tempvar ("complex",
12920                                          ffecom_tree_type
12921                                          [FFEINFO_basictypeCOMPLEX][kt],
12922                                          FFETARGET_charactersizeNONE,
12923                                          -1);
12924           break;
12925
12926         case FFEINFO_basictypeCHARACTER:
12927           if (ffebld_op (expr) != FFEBLD_opFUNCREF)
12928             break;
12929
12930           if (sz == FFETARGET_charactersizeNONE)
12931             /* ~~Kludge alert!  This should someday be fixed. */
12932             sz = 24;
12933
12934           tempvar = ffecom_make_tempvar ("char", char_type_node, sz, -1);
12935           break;
12936
12937         default:
12938           break;
12939         }
12940       break;
12941
12942 #ifdef HAHA
12943     case FFEBLD_opPOWER:
12944       {
12945         tree rtype, ltype;
12946         tree rtmp, ltmp, result;
12947
12948         ltype = ffecom_type_expr (ffebld_left (expr));
12949         rtype = ffecom_type_expr (ffebld_right (expr));
12950
12951         rtmp = ffecom_make_tempvar (rtype, FFETARGET_charactersizeNONE, -1);
12952         ltmp = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12953         result = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12954
12955         tempvar = make_tree_vec (3);
12956         TREE_VEC_ELT (tempvar, 0) = rtmp;
12957         TREE_VEC_ELT (tempvar, 1) = ltmp;
12958         TREE_VEC_ELT (tempvar, 2) = result;
12959       }
12960       break;
12961 #endif  /* HAHA */
12962
12963     case FFEBLD_opCONCATENATE:
12964       {
12965         /* This gets special handling, because only one set of temps
12966            is needed for a tree of these -- the tree is treated as
12967            a flattened list of concatenations when generating code.  */
12968
12969         ffecomConcatList_ catlist;
12970         tree ltmp, itmp, result;
12971         int count;
12972         int i;
12973
12974         catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
12975         count = ffecom_concat_list_count_ (catlist);
12976
12977         if (count >= 2)
12978           {
12979             ltmp
12980               = ffecom_make_tempvar ("concat_len",
12981                                      ffecom_f2c_ftnlen_type_node,
12982                                      FFETARGET_charactersizeNONE, count);
12983             itmp
12984               = ffecom_make_tempvar ("concat_item",
12985                                      ffecom_f2c_address_type_node,
12986                                      FFETARGET_charactersizeNONE, count);
12987             result
12988               = ffecom_make_tempvar ("concat_res",
12989                                      char_type_node,
12990                                      ffecom_concat_list_maxlen_ (catlist),
12991                                      -1);
12992
12993             tempvar = make_tree_vec (3);
12994             TREE_VEC_ELT (tempvar, 0) = ltmp;
12995             TREE_VEC_ELT (tempvar, 1) = itmp;
12996             TREE_VEC_ELT (tempvar, 2) = result;
12997           }
12998
12999         for (i = 0; i < count; ++i)
13000           ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist,
13001                                                                     i));
13002
13003         ffecom_concat_list_kill_ (catlist);
13004
13005         if (tempvar)
13006           {
13007             ffebld_nonter_set_hook (expr, tempvar);
13008             current_binding_level->prep_state = 1;
13009           }
13010       }
13011       return;
13012
13013     case FFEBLD_opCONVERT:
13014       if (bt == FFEINFO_basictypeCHARACTER
13015           && ((ffebld_size_known (ffebld_left (expr))
13016                == FFETARGET_charactersizeNONE)
13017               || (ffebld_size_known (ffebld_left (expr)) >= sz)))
13018         tempvar = ffecom_make_tempvar ("convert", char_type_node, sz, -1);
13019       break;
13020     }
13021
13022   if (tempvar)
13023     {
13024       ffebld_nonter_set_hook (expr, tempvar);
13025       current_binding_level->prep_state = 1;
13026     }
13027
13028   /* Prepare subexpressions for this expr.  */
13029
13030   switch (ffebld_op (expr))
13031     {
13032     case FFEBLD_opPERCENT_LOC:
13033       ffecom_prepare_ptr_to_expr (ffebld_left (expr));
13034       break;
13035
13036     case FFEBLD_opPERCENT_VAL:
13037     case FFEBLD_opPERCENT_REF:
13038       ffecom_prepare_expr (ffebld_left (expr));
13039       break;
13040
13041     case FFEBLD_opPERCENT_DESCR:
13042       ffecom_prepare_arg_ptr_to_expr (ffebld_left (expr));
13043       break;
13044
13045     case FFEBLD_opITEM:
13046       {
13047         ffebld item;
13048
13049         for (item = expr;
13050              item != NULL;
13051              item = ffebld_trail (item))
13052           if (ffebld_head (item) != NULL)
13053             ffecom_prepare_expr (ffebld_head (item));
13054       }
13055       break;
13056
13057     default:
13058       /* Need to handle character conversion specially.  */
13059       switch (ffebld_arity (expr))
13060         {
13061         case 2:
13062           ffecom_prepare_expr (ffebld_left (expr));
13063           ffecom_prepare_expr (ffebld_right (expr));
13064           break;
13065
13066         case 1:
13067           ffecom_prepare_expr (ffebld_left (expr));
13068           break;
13069
13070         default:
13071           break;
13072         }
13073     }
13074
13075   return;
13076 }
13077
13078 /* Prepare expression for reading and writing.
13079
13080    Like ffecom_prepare_expr, except for expressions to be evaluated
13081    via ffecom_expr_rw.  */
13082
13083 void
13084 ffecom_prepare_expr_rw (tree type, ffebld expr)
13085 {
13086   /* This is all we support for now.  */
13087   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
13088
13089   /* ~~For now, it seems to be the same thing.  */
13090   ffecom_prepare_expr (expr);
13091   return;
13092 }
13093
13094 /* Prepare expression for writing.
13095
13096    Like ffecom_prepare_expr, except for expressions to be evaluated
13097    via ffecom_expr_w.  */
13098
13099 void
13100 ffecom_prepare_expr_w (tree type, ffebld expr)
13101 {
13102   /* This is all we support for now.  */
13103   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
13104
13105   /* ~~For now, it seems to be the same thing.  */
13106   ffecom_prepare_expr (expr);
13107   return;
13108 }
13109
13110 /* Prepare expression for returning.
13111
13112    Like ffecom_prepare_expr, except for expressions to be evaluated
13113    via ffecom_return_expr.  */
13114
13115 void
13116 ffecom_prepare_return_expr (ffebld expr)
13117 {
13118   assert (current_binding_level->prep_state < 2);
13119
13120   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE
13121       && ffecom_is_altreturning_
13122       && expr != NULL)
13123     ffecom_prepare_expr (expr);
13124 }
13125
13126 /* Prepare pointer to expression.
13127
13128    Like ffecom_prepare_expr, except for expressions to be evaluated
13129    via ffecom_ptr_to_expr.  */
13130
13131 void
13132 ffecom_prepare_ptr_to_expr (ffebld expr)
13133 {
13134   /* ~~For now, it seems to be the same thing.  */
13135   ffecom_prepare_expr (expr);
13136   return;
13137 }
13138
13139 /* Transform expression into constant pointer-to-expression tree.
13140
13141    If the expression can be transformed into a pointer-to-expression tree
13142    that is constant, that is done, and the tree returned.  Else NULL_TREE
13143    is returned.
13144
13145    That way, a caller can attempt to provide compile-time initialization
13146    of a variable and, if that fails, *then* choose to start a new block
13147    and resort to using temporaries, as appropriate.  */
13148
13149 tree
13150 ffecom_ptr_to_const_expr (ffebld expr)
13151 {
13152   if (! expr)
13153     return integer_zero_node;
13154
13155   if (ffebld_op (expr) == FFEBLD_opANY)
13156     return error_mark_node;
13157
13158   if (ffebld_arity (expr) == 0
13159       && (ffebld_op (expr) != FFEBLD_opSYMTER
13160           || ffebld_where (expr) == FFEINFO_whereCOMMON
13161           || ffebld_where (expr) == FFEINFO_whereGLOBAL
13162           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
13163     {
13164       tree t;
13165
13166       t = ffecom_ptr_to_expr (expr);
13167       assert (TREE_CONSTANT (t));
13168       return t;
13169     }
13170
13171   return NULL_TREE;
13172 }
13173
13174 /* ffecom_return_expr -- Returns return-value expr given alt return expr
13175
13176    tree rtn;  // NULL_TREE means use expand_null_return()
13177    ffebld expr;  // NULL if no alt return expr to RETURN stmt
13178    rtn = ffecom_return_expr(expr);
13179
13180    Based on the program unit type and other info (like return function
13181    type, return master function type when alternate ENTRY points,
13182    whether subroutine has any alternate RETURN points, etc), returns the
13183    appropriate expression to be returned to the caller, or NULL_TREE
13184    meaning no return value or the caller expects it to be returned somewhere
13185    else (which is handled by other parts of this module).  */
13186
13187 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13188 tree
13189 ffecom_return_expr (ffebld expr)
13190 {
13191   tree rtn;
13192
13193   switch (ffecom_primary_entry_kind_)
13194     {
13195     case FFEINFO_kindPROGRAM:
13196     case FFEINFO_kindBLOCKDATA:
13197       rtn = NULL_TREE;
13198       break;
13199
13200     case FFEINFO_kindSUBROUTINE:
13201       if (!ffecom_is_altreturning_)
13202         rtn = NULL_TREE;        /* No alt returns, never an expr. */
13203       else if (expr == NULL)
13204         rtn = integer_zero_node;
13205       else
13206         rtn = ffecom_expr (expr);
13207       break;
13208
13209     case FFEINFO_kindFUNCTION:
13210       if ((ffecom_multi_retval_ != NULL_TREE)
13211           || (ffesymbol_basictype (ffecom_primary_entry_)
13212               == FFEINFO_basictypeCHARACTER)
13213           || ((ffesymbol_basictype (ffecom_primary_entry_)
13214                == FFEINFO_basictypeCOMPLEX)
13215               && (ffecom_num_entrypoints_ == 0)
13216               && ffesymbol_is_f2c (ffecom_primary_entry_)))
13217         {                       /* Value is returned by direct assignment
13218                                    into (implicit) dummy. */
13219           rtn = NULL_TREE;
13220           break;
13221         }
13222       rtn = ffecom_func_result_;
13223 #if 0
13224       /* Spurious error if RETURN happens before first reference!  So elide
13225          this code.  In particular, for debugging registry, rtn should always
13226          be non-null after all, but TREE_USED won't be set until we encounter
13227          a reference in the code.  Perfectly okay (but weird) code that,
13228          e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
13229          this diagnostic for no reason.  Have people use -O -Wuninitialized
13230          and leave it to the back end to find obviously weird cases.  */
13231
13232       /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
13233          situation; if the return value has never been referenced, it won't
13234          have a tree under 2pass mode. */
13235       if ((rtn == NULL_TREE)
13236           || !TREE_USED (rtn))
13237         {
13238           ffebad_start (FFEBAD_RETURN_VALUE_UNSET);
13239           ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_),
13240                        ffesymbol_where_column (ffecom_primary_entry_));
13241           ffebad_string (ffesymbol_text (ffesymbol_funcresult
13242                                          (ffecom_primary_entry_)));
13243           ffebad_finish ();
13244         }
13245 #endif
13246       break;
13247
13248     default:
13249       assert ("bad unit kind" == NULL);
13250     case FFEINFO_kindANY:
13251       rtn = error_mark_node;
13252       break;
13253     }
13254
13255   return rtn;
13256 }
13257
13258 #endif
13259 /* Do save_expr only if tree is not error_mark_node.  */
13260
13261 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13262 tree
13263 ffecom_save_tree (tree t)
13264 {
13265   return save_expr (t);
13266 }
13267 #endif
13268
13269 /* Start a compound statement (block).  */
13270
13271 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13272 void
13273 ffecom_start_compstmt (void)
13274 {
13275   bison_rule_pushlevel_ ();
13276 }
13277 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
13278
13279 /* Public entry point for front end to access start_decl.  */
13280
13281 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13282 tree
13283 ffecom_start_decl (tree decl, bool is_initialized)
13284 {
13285   DECL_INITIAL (decl) = is_initialized ? error_mark_node : NULL_TREE;
13286   return start_decl (decl, FALSE);
13287 }
13288
13289 #endif
13290 /* ffecom_sym_commit -- Symbol's state being committed to reality
13291
13292    ffesymbol s;
13293    ffecom_sym_commit(s);
13294
13295    Does whatever the backend needs when a symbol is committed after having
13296    been backtrackable for a period of time.  */
13297
13298 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13299 void
13300 ffecom_sym_commit (ffesymbol s UNUSED)
13301 {
13302   assert (!ffesymbol_retractable ());
13303 }
13304
13305 #endif
13306 /* ffecom_sym_end_transition -- Perform end transition on all symbols
13307
13308    ffecom_sym_end_transition();
13309
13310    Does backend-specific stuff and also calls ffest_sym_end_transition
13311    to do the necessary FFE stuff.
13312
13313    Backtracking is never enabled when this fn is called, so don't worry
13314    about it.  */
13315
13316 ffesymbol
13317 ffecom_sym_end_transition (ffesymbol s)
13318 {
13319   ffestorag st;
13320
13321   assert (!ffesymbol_retractable ());
13322
13323   s = ffest_sym_end_transition (s);
13324
13325 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13326   if ((ffesymbol_kind (s) == FFEINFO_kindBLOCKDATA)
13327       && (ffesymbol_where (s) == FFEINFO_whereGLOBAL))
13328     {
13329       ffecom_list_blockdata_
13330         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
13331                                               FFEINTRIN_specNONE,
13332                                               FFEINTRIN_impNONE),
13333                            ffecom_list_blockdata_);
13334     }
13335 #endif
13336
13337   /* This is where we finally notice that a symbol has partial initialization
13338      and finalize it. */
13339
13340   if (ffesymbol_accretion (s) != NULL)
13341     {
13342       assert (ffesymbol_init (s) == NULL);
13343       ffecom_notify_init_symbol (s);
13344     }
13345   else if (((st = ffesymbol_storage (s)) != NULL)
13346            && ((st = ffestorag_parent (st)) != NULL)
13347            && (ffestorag_accretion (st) != NULL))
13348     {
13349       assert (ffestorag_init (st) == NULL);
13350       ffecom_notify_init_storage (st);
13351     }
13352
13353 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13354   if ((ffesymbol_kind (s) == FFEINFO_kindCOMMON)
13355       && (ffesymbol_where (s) == FFEINFO_whereLOCAL)
13356       && (ffesymbol_storage (s) != NULL))
13357     {
13358       ffecom_list_common_
13359         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
13360                                               FFEINTRIN_specNONE,
13361                                               FFEINTRIN_impNONE),
13362                            ffecom_list_common_);
13363     }
13364 #endif
13365
13366   return s;
13367 }
13368
13369 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
13370
13371    ffecom_sym_exec_transition();
13372
13373    Does backend-specific stuff and also calls ffest_sym_exec_transition
13374    to do the necessary FFE stuff.
13375
13376    See the long-winded description in ffecom_sym_learned for info
13377    on handling the situation where backtracking is inhibited.  */
13378
13379 ffesymbol
13380 ffecom_sym_exec_transition (ffesymbol s)
13381 {
13382   s = ffest_sym_exec_transition (s);
13383
13384   return s;
13385 }
13386
13387 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
13388
13389    ffesymbol s;
13390    s = ffecom_sym_learned(s);
13391
13392    Called when a new symbol is seen after the exec transition or when more
13393    info (perhaps) is gained for an UNCERTAIN symbol.  The symbol state when
13394    it arrives here is that all its latest info is updated already, so its
13395    state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
13396    field filled in if its gone through here or exec_transition first, and
13397    so on.
13398
13399    The backend probably wants to check ffesymbol_retractable() to see if
13400    backtracking is in effect.  If so, the FFE's changes to the symbol may
13401    be retracted (undone) or committed (ratified), at which time the
13402    appropriate ffecom_sym_retract or _commit function will be called
13403    for that function.
13404
13405    If the backend has its own backtracking mechanism, great, use it so that
13406    committal is a simple operation.  Though it doesn't make much difference,
13407    I suppose: the reason for tentative symbol evolution in the FFE is to
13408    enable error detection in weird incorrect statements early and to disable
13409    incorrect error detection on a correct statement.  The backend is not
13410    likely to introduce any information that'll get involved in these
13411    considerations, so it is probably just fine that the implementation
13412    model for this fn and for _exec_transition is to not do anything
13413    (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
13414    and instead wait until ffecom_sym_commit is called (which it never
13415    will be as long as we're using ambiguity-detecting statement analysis in
13416    the FFE, which we are initially to shake out the code, but don't depend
13417    on this), otherwise go ahead and do whatever is needed.
13418
13419    In essence, then, when this fn and _exec_transition get called while
13420    backtracking is enabled, a general mechanism would be to flag which (or
13421    both) of these were called (and in what order? neat question as to what
13422    might happen that I'm too lame to think through right now) and then when
13423    _commit is called reproduce the original calling sequence, if any, for
13424    the two fns (at which point backtracking will, of course, be disabled).  */
13425
13426 ffesymbol
13427 ffecom_sym_learned (ffesymbol s)
13428 {
13429   ffestorag_exec_layout (s);
13430
13431   return s;
13432 }
13433
13434 /* ffecom_sym_retract -- Symbol's state being retracted from reality
13435
13436    ffesymbol s;
13437    ffecom_sym_retract(s);
13438
13439    Does whatever the backend needs when a symbol is retracted after having
13440    been backtrackable for a period of time.  */
13441
13442 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13443 void
13444 ffecom_sym_retract (ffesymbol s UNUSED)
13445 {
13446   assert (!ffesymbol_retractable ());
13447
13448 #if 0                           /* GCC doesn't commit any backtrackable sins,
13449                                    so nothing needed here. */
13450   switch (ffesymbol_hook (s).state)
13451     {
13452     case 0:                     /* nothing happened yet. */
13453       break;
13454
13455     case 1:                     /* exec transition happened. */
13456       break;
13457
13458     case 2:                     /* learned happened. */
13459       break;
13460
13461     case 3:                     /* learned then exec. */
13462       break;
13463
13464     case 4:                     /* exec then learned. */
13465       break;
13466
13467     default:
13468       assert ("bad hook state" == NULL);
13469       break;
13470     }
13471 #endif
13472 }
13473
13474 #endif
13475 /* Create temporary gcc label.  */
13476
13477 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13478 tree
13479 ffecom_temp_label ()
13480 {
13481   tree glabel;
13482   static int mynumber = 0;
13483
13484   glabel = build_decl (LABEL_DECL,
13485                        ffecom_get_invented_identifier ("__g77_label_%d",
13486                                                        mynumber++),
13487                        void_type_node);
13488   DECL_CONTEXT (glabel) = current_function_decl;
13489   DECL_MODE (glabel) = VOIDmode;
13490
13491   return glabel;
13492 }
13493
13494 #endif
13495 /* Return an expression that is usable as an arg in a conditional context
13496    (IF, DO WHILE, .NOT., and so on).
13497
13498    Use the one provided for the back end as of >2.6.0.  */
13499
13500 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13501 tree
13502 ffecom_truth_value (tree expr)
13503 {
13504   return truthvalue_conversion (expr);
13505 }
13506
13507 #endif
13508 /* Return the inversion of a truth value (the inversion of what
13509    ffecom_truth_value builds).
13510
13511    Apparently invert_truthvalue, which is properly in the back end, is
13512    enough for now, so just use it.  */
13513
13514 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13515 tree
13516 ffecom_truth_value_invert (tree expr)
13517 {
13518   return invert_truthvalue (ffecom_truth_value (expr));
13519 }
13520
13521 #endif
13522
13523 /* Return the tree that is the type of the expression, as would be
13524    returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
13525    transforming the expression, generating temporaries, etc.  */
13526
13527 tree
13528 ffecom_type_expr (ffebld expr)
13529 {
13530   ffeinfoBasictype bt;
13531   ffeinfoKindtype kt;
13532   tree tree_type;
13533
13534   assert (expr != NULL);
13535
13536   bt = ffeinfo_basictype (ffebld_info (expr));
13537   kt = ffeinfo_kindtype (ffebld_info (expr));
13538   tree_type = ffecom_tree_type[bt][kt];
13539
13540   switch (ffebld_op (expr))
13541     {
13542     case FFEBLD_opCONTER:
13543     case FFEBLD_opSYMTER:
13544     case FFEBLD_opARRAYREF:
13545     case FFEBLD_opUPLUS:
13546     case FFEBLD_opPAREN:
13547     case FFEBLD_opUMINUS:
13548     case FFEBLD_opADD:
13549     case FFEBLD_opSUBTRACT:
13550     case FFEBLD_opMULTIPLY:
13551     case FFEBLD_opDIVIDE:
13552     case FFEBLD_opPOWER:
13553     case FFEBLD_opNOT:
13554     case FFEBLD_opFUNCREF:
13555     case FFEBLD_opSUBRREF:
13556     case FFEBLD_opAND:
13557     case FFEBLD_opOR:
13558     case FFEBLD_opXOR:
13559     case FFEBLD_opNEQV:
13560     case FFEBLD_opEQV:
13561     case FFEBLD_opCONVERT:
13562     case FFEBLD_opLT:
13563     case FFEBLD_opLE:
13564     case FFEBLD_opEQ:
13565     case FFEBLD_opNE:
13566     case FFEBLD_opGT:
13567     case FFEBLD_opGE:
13568     case FFEBLD_opPERCENT_LOC:
13569       return tree_type;
13570
13571     case FFEBLD_opACCTER:
13572     case FFEBLD_opARRTER:
13573     case FFEBLD_opITEM:
13574     case FFEBLD_opSTAR:
13575     case FFEBLD_opBOUNDS:
13576     case FFEBLD_opREPEAT:
13577     case FFEBLD_opLABTER:
13578     case FFEBLD_opLABTOK:
13579     case FFEBLD_opIMPDO:
13580     case FFEBLD_opCONCATENATE:
13581     case FFEBLD_opSUBSTR:
13582     default:
13583       assert ("bad op for ffecom_type_expr" == NULL);
13584       /* Fall through. */
13585     case FFEBLD_opANY:
13586       return error_mark_node;
13587     }
13588 }
13589
13590 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13591
13592    If the PARM_DECL already exists, return it, else create it.  It's an
13593    integer_type_node argument for the master function that implements a
13594    subroutine or function with more than one entrypoint and is bound at
13595    run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13596    first ENTRY statement, and so on).  */
13597
13598 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13599 tree
13600 ffecom_which_entrypoint_decl ()
13601 {
13602   assert (ffecom_which_entrypoint_decl_ != NULL_TREE);
13603
13604   return ffecom_which_entrypoint_decl_;
13605 }
13606
13607 #endif
13608 \f
13609 /* The following sections consists of private and public functions
13610    that have the same names and perform roughly the same functions
13611    as counterparts in the C front end.  Changes in the C front end
13612    might affect how things should be done here.  Only functions
13613    needed by the back end should be public here; the rest should
13614    be private (static in the C sense).  Functions needed by other
13615    g77 front-end modules should be accessed by them via public
13616    ffecom_* names, which should themselves call private versions
13617    in this section so the private versions are easy to recognize
13618    when upgrading to a new gcc and finding interesting changes
13619    in the front end.
13620
13621    Functions named after rule "foo:" in c-parse.y are named
13622    "bison_rule_foo_" so they are easy to find.  */
13623
13624 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13625
13626 static void
13627 bison_rule_pushlevel_ ()
13628 {
13629   emit_line_note (input_filename, lineno);
13630   pushlevel (0);
13631   clear_last_expr ();
13632   push_momentary ();
13633   expand_start_bindings (0);
13634 }
13635
13636 static tree
13637 bison_rule_compstmt_ ()
13638 {
13639   tree t;
13640   int keep = kept_level_p ();
13641
13642   /* Make the temps go away.  */
13643   if (! keep)
13644     current_binding_level->names = NULL_TREE;
13645
13646   emit_line_note (input_filename, lineno);
13647   expand_end_bindings (getdecls (), keep, 0);
13648   t = poplevel (keep, 1, 0);
13649   pop_momentary ();
13650
13651   return t;
13652 }
13653
13654 /* Return a definition for a builtin function named NAME and whose data type
13655    is TYPE.  TYPE should be a function type with argument types.
13656    FUNCTION_CODE tells later passes how to compile calls to this function.
13657    See tree.h for its possible values.
13658
13659    If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13660    the name to be called if we can't opencode the function.  */
13661
13662 tree
13663 builtin_function (const char *name, tree type, int function_code,
13664                   enum built_in_class class,
13665                   const char *library_name)
13666 {
13667   tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
13668   DECL_EXTERNAL (decl) = 1;
13669   TREE_PUBLIC (decl) = 1;
13670   if (library_name)
13671     DECL_ASSEMBLER_NAME (decl) = get_identifier (library_name);
13672   make_decl_rtl (decl, NULL_PTR, 1);
13673   pushdecl (decl);
13674   DECL_BUILT_IN_CLASS (decl) = class;
13675   DECL_FUNCTION_CODE (decl) = function_code;
13676
13677   return decl;
13678 }
13679
13680 /* Handle when a new declaration NEWDECL
13681    has the same name as an old one OLDDECL
13682    in the same binding contour.
13683    Prints an error message if appropriate.
13684
13685    If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13686    Otherwise, return 0.  */
13687
13688 static int
13689 duplicate_decls (tree newdecl, tree olddecl)
13690 {
13691   int types_match = 1;
13692   int new_is_definition = (TREE_CODE (newdecl) == FUNCTION_DECL
13693                            && DECL_INITIAL (newdecl) != 0);
13694   tree oldtype = TREE_TYPE (olddecl);
13695   tree newtype = TREE_TYPE (newdecl);
13696
13697   if (olddecl == newdecl)
13698     return 1;
13699
13700   if (TREE_CODE (newtype) == ERROR_MARK
13701       || TREE_CODE (oldtype) == ERROR_MARK)
13702     types_match = 0;
13703
13704   /* New decl is completely inconsistent with the old one =>
13705      tell caller to replace the old one.
13706      This is always an error except in the case of shadowing a builtin.  */
13707   if (TREE_CODE (olddecl) != TREE_CODE (newdecl))
13708     return 0;
13709
13710   /* For real parm decl following a forward decl,
13711      return 1 so old decl will be reused.  */
13712   if (types_match && TREE_CODE (newdecl) == PARM_DECL
13713       && TREE_ASM_WRITTEN (olddecl) && ! TREE_ASM_WRITTEN (newdecl))
13714     return 1;
13715
13716   /* The new declaration is the same kind of object as the old one.
13717      The declarations may partially match.  Print warnings if they don't
13718      match enough.  Ultimately, copy most of the information from the new
13719      decl to the old one, and keep using the old one.  */
13720
13721   if (TREE_CODE (olddecl) == FUNCTION_DECL
13722       && DECL_BUILT_IN (olddecl))
13723     {
13724       /* A function declaration for a built-in function.  */
13725       if (!TREE_PUBLIC (newdecl))
13726         return 0;
13727       else if (!types_match)
13728         {
13729           /* Accept the return type of the new declaration if same modes.  */
13730           tree oldreturntype = TREE_TYPE (TREE_TYPE (olddecl));
13731           tree newreturntype = TREE_TYPE (TREE_TYPE (newdecl));
13732
13733           if (TYPE_MODE (oldreturntype) == TYPE_MODE (newreturntype))
13734             {
13735               /* Function types may be shared, so we can't just modify
13736                  the return type of olddecl's function type.  */
13737               tree newtype
13738                 = build_function_type (newreturntype,
13739                                        TYPE_ARG_TYPES (TREE_TYPE (olddecl)));
13740
13741               types_match = 1;
13742               if (types_match)
13743                 TREE_TYPE (olddecl) = newtype;
13744             }
13745         }
13746       if (!types_match)
13747         return 0;
13748     }
13749   else if (TREE_CODE (olddecl) == FUNCTION_DECL
13750            && DECL_SOURCE_LINE (olddecl) == 0)
13751     {
13752       /* A function declaration for a predeclared function
13753          that isn't actually built in.  */
13754       if (!TREE_PUBLIC (newdecl))
13755         return 0;
13756       else if (!types_match)
13757         {
13758           /* If the types don't match, preserve volatility indication.
13759              Later on, we will discard everything else about the
13760              default declaration.  */
13761           TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl);
13762         }
13763     }
13764
13765   /* Copy all the DECL_... slots specified in the new decl
13766      except for any that we copy here from the old type.
13767
13768      Past this point, we don't change OLDTYPE and NEWTYPE
13769      even if we change the types of NEWDECL and OLDDECL.  */
13770
13771   if (types_match)
13772     {
13773       /* Merge the data types specified in the two decls.  */
13774       if (TREE_CODE (newdecl) != FUNCTION_DECL || !DECL_BUILT_IN (olddecl))
13775         TREE_TYPE (newdecl)
13776           = TREE_TYPE (olddecl)
13777             = TREE_TYPE (newdecl);
13778
13779       /* Lay the type out, unless already done.  */
13780       if (oldtype != TREE_TYPE (newdecl))
13781         {
13782           if (TREE_TYPE (newdecl) != error_mark_node)
13783             layout_type (TREE_TYPE (newdecl));
13784           if (TREE_CODE (newdecl) != FUNCTION_DECL
13785               && TREE_CODE (newdecl) != TYPE_DECL
13786               && TREE_CODE (newdecl) != CONST_DECL)
13787             layout_decl (newdecl, 0);
13788         }
13789       else
13790         {
13791           /* Since the type is OLDDECL's, make OLDDECL's size go with.  */
13792           DECL_SIZE (newdecl) = DECL_SIZE (olddecl);
13793           DECL_SIZE_UNIT (newdecl) = DECL_SIZE_UNIT (olddecl);
13794           if (TREE_CODE (olddecl) != FUNCTION_DECL)
13795             if (DECL_ALIGN (olddecl) > DECL_ALIGN (newdecl))
13796               DECL_ALIGN (newdecl) = DECL_ALIGN (olddecl);
13797         }
13798
13799       /* Keep the old rtl since we can safely use it.  */
13800       DECL_RTL (newdecl) = DECL_RTL (olddecl);
13801
13802       /* Merge the type qualifiers.  */
13803       if (DECL_BUILT_IN_NONANSI (olddecl) && TREE_THIS_VOLATILE (olddecl)
13804           && !TREE_THIS_VOLATILE (newdecl))
13805         TREE_THIS_VOLATILE (olddecl) = 0;
13806       if (TREE_READONLY (newdecl))
13807         TREE_READONLY (olddecl) = 1;
13808       if (TREE_THIS_VOLATILE (newdecl))
13809         {
13810           TREE_THIS_VOLATILE (olddecl) = 1;
13811           if (TREE_CODE (newdecl) == VAR_DECL)
13812             make_var_volatile (newdecl);
13813         }
13814
13815       /* Keep source location of definition rather than declaration.
13816          Likewise, keep decl at outer scope.  */
13817       if ((DECL_INITIAL (newdecl) == 0 && DECL_INITIAL (olddecl) != 0)
13818           || (DECL_CONTEXT (newdecl) != 0 && DECL_CONTEXT (olddecl) == 0))
13819         {
13820           DECL_SOURCE_LINE (newdecl) = DECL_SOURCE_LINE (olddecl);
13821           DECL_SOURCE_FILE (newdecl) = DECL_SOURCE_FILE (olddecl);
13822
13823           if (DECL_CONTEXT (olddecl) == 0
13824               && TREE_CODE (newdecl) != FUNCTION_DECL)
13825             DECL_CONTEXT (newdecl) = 0;
13826         }
13827
13828       /* Merge the unused-warning information.  */
13829       if (DECL_IN_SYSTEM_HEADER (olddecl))
13830         DECL_IN_SYSTEM_HEADER (newdecl) = 1;
13831       else if (DECL_IN_SYSTEM_HEADER (newdecl))
13832         DECL_IN_SYSTEM_HEADER (olddecl) = 1;
13833
13834       /* Merge the initialization information.  */
13835       if (DECL_INITIAL (newdecl) == 0)
13836         DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13837
13838       /* Merge the section attribute.
13839          We want to issue an error if the sections conflict but that must be
13840          done later in decl_attributes since we are called before attributes
13841          are assigned.  */
13842       if (DECL_SECTION_NAME (newdecl) == NULL_TREE)
13843         DECL_SECTION_NAME (newdecl) = DECL_SECTION_NAME (olddecl);
13844
13845 #if BUILT_FOR_270
13846       if (TREE_CODE (newdecl) == FUNCTION_DECL)
13847         {
13848           DECL_STATIC_CONSTRUCTOR(newdecl) |= DECL_STATIC_CONSTRUCTOR(olddecl);
13849           DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl);
13850         }
13851 #endif
13852     }
13853   /* If cannot merge, then use the new type and qualifiers,
13854      and don't preserve the old rtl.  */
13855   else
13856     {
13857       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13858       TREE_READONLY (olddecl) = TREE_READONLY (newdecl);
13859       TREE_THIS_VOLATILE (olddecl) = TREE_THIS_VOLATILE (newdecl);
13860       TREE_SIDE_EFFECTS (olddecl) = TREE_SIDE_EFFECTS (newdecl);
13861     }
13862
13863   /* Merge the storage class information.  */
13864   /* For functions, static overrides non-static.  */
13865   if (TREE_CODE (newdecl) == FUNCTION_DECL)
13866     {
13867       TREE_PUBLIC (newdecl) &= TREE_PUBLIC (olddecl);
13868       /* This is since we don't automatically
13869          copy the attributes of NEWDECL into OLDDECL.  */
13870       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13871       /* If this clears `static', clear it in the identifier too.  */
13872       if (! TREE_PUBLIC (olddecl))
13873         TREE_PUBLIC (DECL_NAME (olddecl)) = 0;
13874     }
13875   if (DECL_EXTERNAL (newdecl))
13876     {
13877       TREE_STATIC (newdecl) = TREE_STATIC (olddecl);
13878       DECL_EXTERNAL (newdecl) = DECL_EXTERNAL (olddecl);
13879       /* An extern decl does not override previous storage class.  */
13880       TREE_PUBLIC (newdecl) = TREE_PUBLIC (olddecl);
13881     }
13882   else
13883     {
13884       TREE_STATIC (olddecl) = TREE_STATIC (newdecl);
13885       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13886     }
13887
13888   /* If either decl says `inline', this fn is inline,
13889      unless its definition was passed already.  */
13890   if (DECL_INLINE (newdecl) && DECL_INITIAL (olddecl) == 0)
13891     DECL_INLINE (olddecl) = 1;
13892   DECL_INLINE (newdecl) = DECL_INLINE (olddecl);
13893
13894   /* Get rid of any built-in function if new arg types don't match it
13895      or if we have a function definition.  */
13896   if (TREE_CODE (newdecl) == FUNCTION_DECL
13897       && DECL_BUILT_IN (olddecl)
13898       && (!types_match || new_is_definition))
13899     {
13900       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13901       DECL_BUILT_IN_CLASS (olddecl) = NOT_BUILT_IN;
13902     }
13903
13904   /* If redeclaring a builtin function, and not a definition,
13905      it stays built in.
13906      Also preserve various other info from the definition.  */
13907   if (TREE_CODE (newdecl) == FUNCTION_DECL && !new_is_definition)
13908     {
13909       if (DECL_BUILT_IN (olddecl))
13910         {
13911           DECL_BUILT_IN_CLASS (newdecl) = DECL_BUILT_IN_CLASS (olddecl);
13912           DECL_FUNCTION_CODE (newdecl) = DECL_FUNCTION_CODE (olddecl);
13913         }
13914       else
13915         DECL_FRAME_SIZE (newdecl) = DECL_FRAME_SIZE (olddecl);
13916
13917       DECL_RESULT (newdecl) = DECL_RESULT (olddecl);
13918       DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13919       DECL_SAVED_INSNS (newdecl) = DECL_SAVED_INSNS (olddecl);
13920       DECL_ARGUMENTS (newdecl) = DECL_ARGUMENTS (olddecl);
13921     }
13922
13923   /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13924      But preserve olddecl's DECL_UID.  */
13925   {
13926     register unsigned olddecl_uid = DECL_UID (olddecl);
13927
13928     memcpy ((char *) olddecl + sizeof (struct tree_common),
13929             (char *) newdecl + sizeof (struct tree_common),
13930             sizeof (struct tree_decl) - sizeof (struct tree_common));
13931     DECL_UID (olddecl) = olddecl_uid;
13932   }
13933
13934   return 1;
13935 }
13936
13937 /* Finish processing of a declaration;
13938    install its initial value.
13939    If the length of an array type is not known before,
13940    it must be determined now, from the initial value, or it is an error.  */
13941
13942 static void
13943 finish_decl (tree decl, tree init, bool is_top_level)
13944 {
13945   register tree type = TREE_TYPE (decl);
13946   int was_incomplete = (DECL_SIZE (decl) == 0);
13947   int temporary = allocation_temporary_p ();
13948   bool at_top_level = (current_binding_level == global_binding_level);
13949   bool top_level = is_top_level || at_top_level;
13950
13951   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13952      level anyway.  */
13953   assert (!is_top_level || !at_top_level);
13954
13955   if (TREE_CODE (decl) == PARM_DECL)
13956     assert (init == NULL_TREE);
13957   /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
13958      overlaps DECL_ARG_TYPE.  */
13959   else if (init == NULL_TREE)
13960     assert (DECL_INITIAL (decl) == NULL_TREE);
13961   else
13962     assert (DECL_INITIAL (decl) == error_mark_node);
13963
13964   if (init != NULL_TREE)
13965     {
13966       if (TREE_CODE (decl) != TYPE_DECL)
13967         DECL_INITIAL (decl) = init;
13968       else
13969         {
13970           /* typedef foo = bar; store the type of bar as the type of foo.  */
13971           TREE_TYPE (decl) = TREE_TYPE (init);
13972           DECL_INITIAL (decl) = init = 0;
13973         }
13974     }
13975
13976   /* Pop back to the obstack that is current for this binding level. This is
13977      because MAXINDEX, rtl, etc. to be made below must go in the permanent
13978      obstack.  But don't discard the temporary data yet.  */
13979   pop_obstacks ();
13980
13981   /* Deduce size of array from initialization, if not already known */
13982
13983   if (TREE_CODE (type) == ARRAY_TYPE
13984       && TYPE_DOMAIN (type) == 0
13985       && TREE_CODE (decl) != TYPE_DECL)
13986     {
13987       assert (top_level);
13988       assert (was_incomplete);
13989
13990       layout_decl (decl, 0);
13991     }
13992
13993   if (TREE_CODE (decl) == VAR_DECL)
13994     {
13995       if (DECL_SIZE (decl) == NULL_TREE
13996           && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
13997         layout_decl (decl, 0);
13998
13999       if (DECL_SIZE (decl) == NULL_TREE
14000           && (TREE_STATIC (decl)
14001               ?
14002       /* A static variable with an incomplete type is an error if it is
14003          initialized. Also if it is not file scope. Otherwise, let it
14004          through, but if it is not `extern' then it may cause an error
14005          message later.  */
14006               (DECL_INITIAL (decl) != 0 || DECL_CONTEXT (decl) != 0)
14007               :
14008       /* An automatic variable with an incomplete type is an error.  */
14009               !DECL_EXTERNAL (decl)))
14010         {
14011           assert ("storage size not known" == NULL);
14012           abort ();
14013         }
14014
14015       if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
14016           && (DECL_SIZE (decl) != 0)
14017           && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
14018         {
14019           assert ("storage size not constant" == NULL);
14020           abort ();
14021         }
14022     }
14023
14024   /* Output the assembler code and/or RTL code for variables and functions,
14025      unless the type is an undefined structure or union. If not, it will get
14026      done when the type is completed.  */
14027
14028   if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL)
14029     {
14030       rest_of_decl_compilation (decl, NULL,
14031                                 DECL_CONTEXT (decl) == 0,
14032                                 0);
14033
14034       if (DECL_CONTEXT (decl) != 0)
14035         {
14036           /* Recompute the RTL of a local array now if it used to be an
14037              incomplete type.  */
14038           if (was_incomplete
14039               && !TREE_STATIC (decl) && !DECL_EXTERNAL (decl))
14040             {
14041               /* If we used it already as memory, it must stay in memory.  */
14042               TREE_ADDRESSABLE (decl) = TREE_USED (decl);
14043               /* If it's still incomplete now, no init will save it.  */
14044               if (DECL_SIZE (decl) == 0)
14045                 DECL_INITIAL (decl) = 0;
14046               expand_decl (decl);
14047             }
14048           /* Compute and store the initial value.  */
14049           if (TREE_CODE (decl) != FUNCTION_DECL)
14050             expand_decl_init (decl);
14051         }
14052     }
14053   else if (TREE_CODE (decl) == TYPE_DECL)
14054     {
14055       rest_of_decl_compilation (decl, NULL_PTR,
14056                                 DECL_CONTEXT (decl) == 0,
14057                                 0);
14058     }
14059
14060   if (!(TREE_CODE (decl) == FUNCTION_DECL && DECL_INLINE (decl))
14061       && temporary
14062   /* DECL_INITIAL is not defined in PARM_DECLs, since it shares space with
14063      DECL_ARG_TYPE.  */
14064       && TREE_CODE (decl) != PARM_DECL)
14065     {
14066       /* We need to remember that this array HAD an initialization, but
14067          discard the actual temporary nodes, since we can't have a permanent
14068          node keep pointing to them.  */
14069       /* We make an exception for inline functions, since it's normal for a
14070          local extern redeclaration of an inline function to have a copy of
14071          the top-level decl's DECL_INLINE.  */
14072       if ((DECL_INITIAL (decl) != 0)
14073           && (DECL_INITIAL (decl) != error_mark_node))
14074         {
14075           /* If this is a const variable, then preserve the
14076              initializer instead of discarding it so that we can optimize
14077              references to it.  */
14078           /* This test used to include TREE_STATIC, but this won't be set
14079              for function level initializers.  */
14080           if (TREE_READONLY (decl))
14081             {
14082               preserve_initializer ();
14083
14084               /* The initializer and DECL must have the same (or equivalent
14085                  types), but if the initializer is a STRING_CST, its type
14086                  might not be on the right obstack, so copy the type
14087                  of DECL.  */
14088               TREE_TYPE (DECL_INITIAL (decl)) = type;
14089             }
14090           else
14091             DECL_INITIAL (decl) = error_mark_node;
14092         }
14093     }
14094
14095   /* If we have gone back from temporary to permanent allocation, actually
14096      free the temporary space that we no longer need.  */
14097   if (temporary && !allocation_temporary_p ())
14098     permanent_allocation (0);
14099
14100   /* At the end of a declaration, throw away any variable type sizes of types
14101      defined inside that declaration.  There is no use computing them in the
14102      following function definition.  */
14103   if (current_binding_level == global_binding_level)
14104     get_pending_sizes ();
14105 }
14106
14107 /* Finish up a function declaration and compile that function
14108    all the way to assembler language output.  The free the storage
14109    for the function definition.
14110
14111    This is called after parsing the body of the function definition.
14112
14113    NESTED is nonzero if the function being finished is nested in another.  */
14114
14115 static void
14116 finish_function (int nested)
14117 {
14118   register tree fndecl = current_function_decl;
14119
14120   assert (fndecl != NULL_TREE);
14121   if (TREE_CODE (fndecl) != ERROR_MARK)
14122     {
14123       if (nested)
14124         assert (DECL_CONTEXT (fndecl) != NULL_TREE);
14125       else
14126         assert (DECL_CONTEXT (fndecl) == NULL_TREE);
14127     }
14128
14129 /*  TREE_READONLY (fndecl) = 1;
14130     This caused &foo to be of type ptr-to-const-function
14131     which then got a warning when stored in a ptr-to-function variable.  */
14132
14133   poplevel (1, 0, 1);
14134
14135   if (TREE_CODE (fndecl) != ERROR_MARK)
14136     {
14137       BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
14138
14139       /* Must mark the RESULT_DECL as being in this function.  */
14140
14141       DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
14142
14143       /* Obey `register' declarations if `setjmp' is called in this fn.  */
14144       /* Generate rtl for function exit.  */
14145       expand_function_end (input_filename, lineno, 0);
14146
14147       /* So we can tell if jump_optimize sets it to 1.  */
14148       can_reach_end = 0;
14149
14150       /* If this is a nested function, protect the local variables in the stack
14151          above us from being collected while we're compiling this function.  */
14152       if (ggc_p && nested)
14153         ggc_push_context ();
14154
14155       /* Run the optimizers and output the assembler code for this function.  */
14156       rest_of_compilation (fndecl);
14157
14158       /* Undo the GC context switch.  */
14159       if (ggc_p && nested)
14160         ggc_pop_context ();
14161     }
14162
14163   /* Free all the tree nodes making up this function.  */
14164   /* Switch back to allocating nodes permanently until we start another
14165      function.  */
14166   if (!nested)
14167     permanent_allocation (1);
14168
14169   if (TREE_CODE (fndecl) != ERROR_MARK
14170       && !nested
14171       && DECL_SAVED_INSNS (fndecl) == 0)
14172     {
14173       /* Stop pointing to the local nodes about to be freed.  */
14174       /* But DECL_INITIAL must remain nonzero so we know this was an actual
14175          function definition.  */
14176       /* For a nested function, this is done in pop_f_function_context.  */
14177       /* If rest_of_compilation set this to 0, leave it 0.  */
14178       if (DECL_INITIAL (fndecl) != 0)
14179         DECL_INITIAL (fndecl) = error_mark_node;
14180       DECL_ARGUMENTS (fndecl) = 0;
14181     }
14182
14183   if (!nested)
14184     {
14185       /* Let the error reporting routines know that we're outside a function.
14186          For a nested function, this value is used in pop_c_function_context
14187          and then reset via pop_function_context.  */
14188       ffecom_outer_function_decl_ = current_function_decl = NULL;
14189     }
14190 }
14191
14192 /* Plug-in replacement for identifying the name of a decl and, for a
14193    function, what we call it in diagnostics.  For now, "program unit"
14194    should suffice, since it's a bit of a hassle to figure out which
14195    of several kinds of things it is.  Note that it could conceivably
14196    be a statement function, which probably isn't really a program unit
14197    per se, but if that comes up, it should be easy to check (being a
14198    nested function and all).  */
14199
14200 static const char *
14201 lang_printable_name (tree decl, int v)
14202 {
14203   /* Just to keep GCC quiet about the unused variable.
14204      In theory, differing values of V should produce different
14205      output.  */
14206   switch (v)
14207     {
14208     default:
14209       if (TREE_CODE (decl) == ERROR_MARK)
14210         return "erroneous code";
14211       return IDENTIFIER_POINTER (DECL_NAME (decl));
14212     }
14213 }
14214
14215 /* g77's function to print out name of current function that caused
14216    an error.  */
14217
14218 #if BUILT_FOR_270
14219 static void
14220 lang_print_error_function (const char *file)
14221 {
14222   static ffeglobal last_g = NULL;
14223   static ffesymbol last_s = NULL;
14224   ffeglobal g;
14225   ffesymbol s;
14226   const char *kind;
14227
14228   if ((ffecom_primary_entry_ == NULL)
14229       || (ffesymbol_global (ffecom_primary_entry_) == NULL))
14230     {
14231       g = NULL;
14232       s = NULL;
14233       kind = NULL;
14234     }
14235   else
14236     {
14237       g = ffesymbol_global (ffecom_primary_entry_);
14238       if (ffecom_nested_entry_ == NULL)
14239         {
14240           s = ffecom_primary_entry_;
14241           switch (ffesymbol_kind (s))
14242             {
14243             case FFEINFO_kindFUNCTION:
14244               kind = "function";
14245               break;
14246
14247             case FFEINFO_kindSUBROUTINE:
14248               kind = "subroutine";
14249               break;
14250
14251             case FFEINFO_kindPROGRAM:
14252               kind = "program";
14253               break;
14254
14255             case FFEINFO_kindBLOCKDATA:
14256               kind = "block-data";
14257               break;
14258
14259             default:
14260               kind = ffeinfo_kind_message (ffesymbol_kind (s));
14261               break;
14262             }
14263         }
14264       else
14265         {
14266           s = ffecom_nested_entry_;
14267           kind = "statement function";
14268         }
14269     }
14270
14271   if ((last_g != g) || (last_s != s))
14272     {
14273       if (file)
14274         fprintf (stderr, "%s: ", file);
14275
14276       if (s == NULL)
14277         fprintf (stderr, "Outside of any program unit:\n");
14278       else
14279         {
14280           const char *name = ffesymbol_text (s);
14281
14282           fprintf (stderr, "In %s `%s':\n", kind, name);
14283         }
14284
14285       last_g = g;
14286       last_s = s;
14287     }
14288 }
14289 #endif
14290
14291 /* Similar to `lookup_name' but look only at current binding level.  */
14292
14293 static tree
14294 lookup_name_current_level (tree name)
14295 {
14296   register tree t;
14297
14298   if (current_binding_level == global_binding_level)
14299     return IDENTIFIER_GLOBAL_VALUE (name);
14300
14301   if (IDENTIFIER_LOCAL_VALUE (name) == 0)
14302     return 0;
14303
14304   for (t = current_binding_level->names; t; t = TREE_CHAIN (t))
14305     if (DECL_NAME (t) == name)
14306       break;
14307
14308   return t;
14309 }
14310
14311 /* Create a new `struct binding_level'.  */
14312
14313 static struct binding_level *
14314 make_binding_level ()
14315 {
14316   /* NOSTRICT */
14317   return (struct binding_level *) xmalloc (sizeof (struct binding_level));
14318 }
14319
14320 /* Save and restore the variables in this file and elsewhere
14321    that keep track of the progress of compilation of the current function.
14322    Used for nested functions.  */
14323
14324 struct f_function
14325 {
14326   struct f_function *next;
14327   tree named_labels;
14328   tree shadowed_labels;
14329   struct binding_level *binding_level;
14330 };
14331
14332 struct f_function *f_function_chain;
14333
14334 /* Restore the variables used during compilation of a C function.  */
14335
14336 static void
14337 pop_f_function_context ()
14338 {
14339   struct f_function *p = f_function_chain;
14340   tree link;
14341
14342   /* Bring back all the labels that were shadowed.  */
14343   for (link = shadowed_labels; link; link = TREE_CHAIN (link))
14344     if (DECL_NAME (TREE_VALUE (link)) != 0)
14345       IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link)))
14346         = TREE_VALUE (link);
14347
14348   if (current_function_decl != error_mark_node
14349       && DECL_SAVED_INSNS (current_function_decl) == 0)
14350     {
14351       /* Stop pointing to the local nodes about to be freed.  */
14352       /* But DECL_INITIAL must remain nonzero so we know this was an actual
14353          function definition.  */
14354       DECL_INITIAL (current_function_decl) = error_mark_node;
14355       DECL_ARGUMENTS (current_function_decl) = 0;
14356     }
14357
14358   pop_function_context ();
14359
14360   f_function_chain = p->next;
14361
14362   named_labels = p->named_labels;
14363   shadowed_labels = p->shadowed_labels;
14364   current_binding_level = p->binding_level;
14365
14366   free (p);
14367 }
14368
14369 /* Save and reinitialize the variables
14370    used during compilation of a C function.  */
14371
14372 static void
14373 push_f_function_context ()
14374 {
14375   struct f_function *p
14376   = (struct f_function *) xmalloc (sizeof (struct f_function));
14377
14378   push_function_context ();
14379
14380   p->next = f_function_chain;
14381   f_function_chain = p;
14382
14383   p->named_labels = named_labels;
14384   p->shadowed_labels = shadowed_labels;
14385   p->binding_level = current_binding_level;
14386 }
14387
14388 static void
14389 push_parm_decl (tree parm)
14390 {
14391   int old_immediate_size_expand = immediate_size_expand;
14392
14393   /* Don't try computing parm sizes now -- wait till fn is called.  */
14394
14395   immediate_size_expand = 0;
14396
14397   push_obstacks_nochange ();
14398
14399   /* Fill in arg stuff.  */
14400
14401   DECL_ARG_TYPE (parm) = TREE_TYPE (parm);
14402   DECL_ARG_TYPE_AS_WRITTEN (parm) = TREE_TYPE (parm);
14403   TREE_READONLY (parm) = 1;     /* All implementation args are read-only. */
14404
14405   parm = pushdecl (parm);
14406
14407   immediate_size_expand = old_immediate_size_expand;
14408
14409   finish_decl (parm, NULL_TREE, FALSE);
14410 }
14411
14412 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate.  */
14413
14414 static tree
14415 pushdecl_top_level (x)
14416      tree x;
14417 {
14418   register tree t;
14419   register struct binding_level *b = current_binding_level;
14420   register tree f = current_function_decl;
14421
14422   current_binding_level = global_binding_level;
14423   current_function_decl = NULL_TREE;
14424   t = pushdecl (x);
14425   current_binding_level = b;
14426   current_function_decl = f;
14427   return t;
14428 }
14429
14430 /* Store the list of declarations of the current level.
14431    This is done for the parameter declarations of a function being defined,
14432    after they are modified in the light of any missing parameters.  */
14433
14434 static tree
14435 storedecls (decls)
14436      tree decls;
14437 {
14438   return current_binding_level->names = decls;
14439 }
14440
14441 /* Store the parameter declarations into the current function declaration.
14442    This is called after parsing the parameter declarations, before
14443    digesting the body of the function.
14444
14445    For an old-style definition, modify the function's type
14446    to specify at least the number of arguments.  */
14447
14448 static void
14449 store_parm_decls (int is_main_program UNUSED)
14450 {
14451   register tree fndecl = current_function_decl;
14452
14453   if (fndecl == error_mark_node)
14454     return;
14455
14456   /* This is a chain of PARM_DECLs from old-style parm declarations.  */
14457   DECL_ARGUMENTS (fndecl) = storedecls (nreverse (getdecls ()));
14458
14459   /* Initialize the RTL code for the function.  */
14460
14461   init_function_start (fndecl, input_filename, lineno);
14462
14463   /* Set up parameters and prepare for return, for the function.  */
14464
14465   expand_function_start (fndecl, 0);
14466 }
14467
14468 static tree
14469 start_decl (tree decl, bool is_top_level)
14470 {
14471   register tree tem;
14472   bool at_top_level = (current_binding_level == global_binding_level);
14473   bool top_level = is_top_level || at_top_level;
14474
14475   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
14476      level anyway.  */
14477   assert (!is_top_level || !at_top_level);
14478
14479   /* The corresponding pop_obstacks is in finish_decl.  */
14480   push_obstacks_nochange ();
14481
14482   if (DECL_INITIAL (decl) != NULL_TREE)
14483     {
14484       assert (DECL_INITIAL (decl) == error_mark_node);
14485       assert (!DECL_EXTERNAL (decl));
14486     }
14487   else if (top_level)
14488     assert ((TREE_STATIC (decl) == 1) || DECL_EXTERNAL (decl) == 1);
14489
14490   /* For Fortran, we by default put things in .common when possible.  */
14491   DECL_COMMON (decl) = 1;
14492
14493   /* Add this decl to the current binding level. TEM may equal DECL or it may
14494      be a previous decl of the same name.  */
14495   if (is_top_level)
14496     tem = pushdecl_top_level (decl);
14497   else
14498     tem = pushdecl (decl);
14499
14500   /* For a local variable, define the RTL now.  */
14501   if (!top_level
14502   /* But not if this is a duplicate decl and we preserved the rtl from the
14503      previous one (which may or may not happen).  */
14504       && DECL_RTL (tem) == 0)
14505     {
14506       if (TYPE_SIZE (TREE_TYPE (tem)) != 0)
14507         expand_decl (tem);
14508       else if (TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE
14509                && DECL_INITIAL (tem) != 0)
14510         expand_decl (tem);
14511     }
14512
14513   if (DECL_INITIAL (tem) != NULL_TREE)
14514     {
14515       /* When parsing and digesting the initializer, use temporary storage.
14516          Do this even if we will ignore the value.  */
14517       if (at_top_level)
14518         temporary_allocation ();
14519     }
14520
14521   return tem;
14522 }
14523
14524 /* Create the FUNCTION_DECL for a function definition.
14525    DECLSPECS and DECLARATOR are the parts of the declaration;
14526    they describe the function's name and the type it returns,
14527    but twisted together in a fashion that parallels the syntax of C.
14528
14529    This function creates a binding context for the function body
14530    as well as setting up the FUNCTION_DECL in current_function_decl.
14531
14532    Returns 1 on success.  If the DECLARATOR is not suitable for a function
14533    (it defines a datum instead), we return 0, which tells
14534    yyparse to report a parse error.
14535
14536    NESTED is nonzero for a function nested within another function.  */
14537
14538 static void
14539 start_function (tree name, tree type, int nested, int public)
14540 {
14541   tree decl1;
14542   tree restype;
14543   int old_immediate_size_expand = immediate_size_expand;
14544
14545   named_labels = 0;
14546   shadowed_labels = 0;
14547
14548   /* Don't expand any sizes in the return type of the function.  */
14549   immediate_size_expand = 0;
14550
14551   if (nested)
14552     {
14553       assert (!public);
14554       assert (current_function_decl != NULL_TREE);
14555       assert (DECL_CONTEXT (current_function_decl) == NULL_TREE);
14556     }
14557   else
14558     {
14559       assert (current_function_decl == NULL_TREE);
14560     }
14561
14562   if (TREE_CODE (type) == ERROR_MARK)
14563     decl1 = current_function_decl = error_mark_node;
14564   else
14565     {
14566       decl1 = build_decl (FUNCTION_DECL,
14567                           name,
14568                           type);
14569       TREE_PUBLIC (decl1) = public ? 1 : 0;
14570       if (nested)
14571         DECL_INLINE (decl1) = 1;
14572       TREE_STATIC (decl1) = 1;
14573       DECL_EXTERNAL (decl1) = 0;
14574
14575       announce_function (decl1);
14576
14577       /* Make the init_value nonzero so pushdecl knows this is not tentative.
14578          error_mark_node is replaced below (in poplevel) with the BLOCK.  */
14579       DECL_INITIAL (decl1) = error_mark_node;
14580
14581       /* Record the decl so that the function name is defined. If we already have
14582          a decl for this name, and it is a FUNCTION_DECL, use the old decl.  */
14583
14584       current_function_decl = pushdecl (decl1);
14585     }
14586
14587   if (!nested)
14588     ffecom_outer_function_decl_ = current_function_decl;
14589
14590   pushlevel (0);
14591   current_binding_level->prep_state = 2;
14592
14593   if (TREE_CODE (current_function_decl) != ERROR_MARK)
14594     {
14595       make_function_rtl (current_function_decl);
14596
14597       restype = TREE_TYPE (TREE_TYPE (current_function_decl));
14598       DECL_RESULT (current_function_decl)
14599         = build_decl (RESULT_DECL, NULL_TREE, restype);
14600     }
14601
14602   if (!nested)
14603     /* Allocate further tree nodes temporarily during compilation of this
14604        function only.  */
14605     temporary_allocation ();
14606
14607   if (!nested && (TREE_CODE (current_function_decl) != ERROR_MARK))
14608     TREE_ADDRESSABLE (current_function_decl) = 1;
14609
14610   immediate_size_expand = old_immediate_size_expand;
14611 }
14612 \f
14613 /* Here are the public functions the GNU back end needs.  */
14614
14615 tree
14616 convert (type, expr)
14617      tree type, expr;
14618 {
14619   register tree e = expr;
14620   register enum tree_code code = TREE_CODE (type);
14621
14622   if (type == TREE_TYPE (e)
14623       || TREE_CODE (e) == ERROR_MARK)
14624     return e;
14625   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
14626     return fold (build1 (NOP_EXPR, type, e));
14627   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
14628       || code == ERROR_MARK)
14629     return error_mark_node;
14630   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
14631     {
14632       assert ("void value not ignored as it ought to be" == NULL);
14633       return error_mark_node;
14634     }
14635   if (code == VOID_TYPE)
14636     return build1 (CONVERT_EXPR, type, e);
14637   if ((code != RECORD_TYPE)
14638       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
14639     e = ffecom_1 (REALPART_EXPR, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))),
14640                   e);
14641   if (code == INTEGER_TYPE || code == ENUMERAL_TYPE)
14642     return fold (convert_to_integer (type, e));
14643   if (code == POINTER_TYPE)
14644     return fold (convert_to_pointer (type, e));
14645   if (code == REAL_TYPE)
14646     return fold (convert_to_real (type, e));
14647   if (code == COMPLEX_TYPE)
14648     return fold (convert_to_complex (type, e));
14649   if (code == RECORD_TYPE)
14650     return fold (ffecom_convert_to_complex_ (type, e));
14651
14652   assert ("conversion to non-scalar type requested" == NULL);
14653   return error_mark_node;
14654 }
14655
14656 /* integrate_decl_tree calls this function, but since we don't use the
14657    DECL_LANG_SPECIFIC field, this is a no-op.  */
14658
14659 void
14660 copy_lang_decl (node)
14661      tree node UNUSED;
14662 {
14663 }
14664
14665 /* Return the list of declarations of the current level.
14666    Note that this list is in reverse order unless/until
14667    you nreverse it; and when you do nreverse it, you must
14668    store the result back using `storedecls' or you will lose.  */
14669
14670 tree
14671 getdecls ()
14672 {
14673   return current_binding_level->names;
14674 }
14675
14676 /* Nonzero if we are currently in the global binding level.  */
14677
14678 int
14679 global_bindings_p ()
14680 {
14681   return current_binding_level == global_binding_level;
14682 }
14683
14684 /* Print an error message for invalid use of an incomplete type.
14685    VALUE is the expression that was used (or 0 if that isn't known)
14686    and TYPE is the type that was invalid.  */
14687
14688 void
14689 incomplete_type_error (value, type)
14690      tree value UNUSED;
14691      tree type;
14692 {
14693   if (TREE_CODE (type) == ERROR_MARK)
14694     return;
14695
14696   assert ("incomplete type?!?" == NULL);
14697 }
14698
14699 /* Mark ARG for GC.  */
14700 static void
14701 mark_binding_level (void *arg)
14702 {
14703   struct binding_level *level = *(struct binding_level **) arg;
14704
14705   while (level)
14706     {
14707       ggc_mark_tree (level->names);
14708       ggc_mark_tree (level->blocks);
14709       ggc_mark_tree (level->this_block);
14710       level = level->level_chain;
14711     }
14712 }
14713
14714 void
14715 init_decl_processing ()
14716 {
14717   static tree *const tree_roots[] = {
14718     &current_function_decl,
14719     &string_type_node,
14720     &ffecom_tree_fun_type_void,
14721     &ffecom_integer_zero_node,
14722     &ffecom_integer_one_node,
14723     &ffecom_tree_subr_type,
14724     &ffecom_tree_ptr_to_subr_type,
14725     &ffecom_tree_blockdata_type,
14726     &ffecom_tree_xargc_,
14727     &ffecom_f2c_integer_type_node,
14728     &ffecom_f2c_ptr_to_integer_type_node,
14729     &ffecom_f2c_address_type_node,
14730     &ffecom_f2c_real_type_node,
14731     &ffecom_f2c_ptr_to_real_type_node,
14732     &ffecom_f2c_doublereal_type_node,
14733     &ffecom_f2c_complex_type_node,
14734     &ffecom_f2c_doublecomplex_type_node,
14735     &ffecom_f2c_longint_type_node,
14736     &ffecom_f2c_logical_type_node,
14737     &ffecom_f2c_flag_type_node,
14738     &ffecom_f2c_ftnlen_type_node,
14739     &ffecom_f2c_ftnlen_zero_node,
14740     &ffecom_f2c_ftnlen_one_node,
14741     &ffecom_f2c_ftnlen_two_node,
14742     &ffecom_f2c_ptr_to_ftnlen_type_node,
14743     &ffecom_f2c_ftnint_type_node,
14744     &ffecom_f2c_ptr_to_ftnint_type_node,
14745     &ffecom_outer_function_decl_,
14746     &ffecom_previous_function_decl_,
14747     &ffecom_which_entrypoint_decl_,
14748     &ffecom_float_zero_,
14749     &ffecom_float_half_,
14750     &ffecom_double_zero_,
14751     &ffecom_double_half_,
14752     &ffecom_func_result_,
14753     &ffecom_func_length_,
14754     &ffecom_multi_type_node_,
14755     &ffecom_multi_retval_,
14756     &named_labels,
14757     &shadowed_labels
14758   };
14759   size_t i;
14760
14761   malloc_init ();
14762
14763   /* Record our roots.  */
14764   for (i = 0; i < sizeof(tree_roots)/sizeof(tree_roots[0]); i++)
14765     ggc_add_tree_root (tree_roots[i], 1);
14766   ggc_add_tree_root (&ffecom_tree_type[0][0],
14767                      FFEINFO_basictype*FFEINFO_kindtype);
14768   ggc_add_tree_root (&ffecom_tree_fun_type[0][0],
14769                      FFEINFO_basictype*FFEINFO_kindtype);
14770   ggc_add_tree_root (&ffecom_tree_ptr_to_fun_type[0][0],
14771                      FFEINFO_basictype*FFEINFO_kindtype);
14772   ggc_add_tree_root (ffecom_gfrt_, FFECOM_gfrt);
14773   ggc_add_root (&current_binding_level, 1, sizeof current_binding_level,
14774                 mark_binding_level);
14775   ggc_add_root (&free_binding_level, 1, sizeof current_binding_level,
14776                 mark_binding_level);
14777   ggc_add_root (&tracker_head, 1, sizeof tracker_head, mark_tracker_head);
14778
14779   ffe_init_0 ();
14780 }
14781
14782 char *
14783 init_parse (filename)
14784      char *filename;
14785 {
14786   /* Open input file.  */
14787   if (filename == 0 || !strcmp (filename, "-"))
14788     {
14789       finput = stdin;
14790       filename = "stdin";
14791     }
14792   else
14793     finput = fopen (filename, "r");
14794   if (finput == 0)
14795     pfatal_with_name (filename);
14796
14797 #ifdef IO_BUFFER_SIZE
14798   setvbuf (finput, (char *) xmalloc (IO_BUFFER_SIZE), _IOFBF, IO_BUFFER_SIZE);
14799 #endif
14800
14801   /* Make identifier nodes long enough for the language-specific slots.  */
14802   set_identifier_size (sizeof (struct lang_identifier));
14803   decl_printable_name = lang_printable_name;
14804 #if BUILT_FOR_270
14805   print_error_function = lang_print_error_function;
14806 #endif
14807
14808   return filename;
14809 }
14810
14811 void
14812 finish_parse ()
14813 {
14814   fclose (finput);
14815 }
14816
14817 /* Delete the node BLOCK from the current binding level.
14818    This is used for the block inside a stmt expr ({...})
14819    so that the block can be reinserted where appropriate.  */
14820
14821 static void
14822 delete_block (block)
14823      tree block;
14824 {
14825   tree t;
14826   if (current_binding_level->blocks == block)
14827     current_binding_level->blocks = TREE_CHAIN (block);
14828   for (t = current_binding_level->blocks; t;)
14829     {
14830       if (TREE_CHAIN (t) == block)
14831         TREE_CHAIN (t) = TREE_CHAIN (block);
14832       else
14833         t = TREE_CHAIN (t);
14834     }
14835   TREE_CHAIN (block) = NULL;
14836   /* Clear TREE_USED which is always set by poplevel.
14837      The flag is set again if insert_block is called.  */
14838   TREE_USED (block) = 0;
14839 }
14840
14841 void
14842 insert_block (block)
14843      tree block;
14844 {
14845   TREE_USED (block) = 1;
14846   current_binding_level->blocks
14847     = chainon (current_binding_level->blocks, block);
14848 }
14849
14850 int
14851 lang_decode_option (argc, argv)
14852      int argc;
14853      char **argv;
14854 {
14855   return ffe_decode_option (argc, argv);
14856 }
14857
14858 /* used by print-tree.c */
14859
14860 void
14861 lang_print_xnode (file, node, indent)
14862      FILE *file UNUSED;
14863      tree node UNUSED;
14864      int indent UNUSED;
14865 {
14866 }
14867
14868 void
14869 lang_finish ()
14870 {
14871   ffe_terminate_0 ();
14872
14873   if (ffe_is_ffedebug ())
14874     malloc_pool_display (malloc_pool_image ());
14875 }
14876
14877 const char *
14878 lang_identify ()
14879 {
14880   return "f77";
14881 }
14882
14883 void
14884 lang_init_options ()
14885 {
14886   /* Set default options for Fortran.  */
14887   flag_move_all_movables = 1;
14888   flag_reduce_all_givs = 1;
14889   flag_argument_noalias = 2;
14890   flag_errno_math = 0;
14891   flag_complex_divide_method = 1;
14892 }
14893
14894 void
14895 lang_init ()
14896 {
14897   /* If the file is output from cpp, it should contain a first line
14898      `# 1 "real-filename"', and the current design of gcc (toplev.c
14899      in particular and the way it sets up information relied on by
14900      INCLUDE) requires that we read this now, and store the
14901      "real-filename" info in master_input_filename.  Ask the lexer
14902      to try doing this.  */
14903   ffelex_hash_kludge (finput);
14904 }
14905
14906 int
14907 mark_addressable (exp)
14908      tree exp;
14909 {
14910   register tree x = exp;
14911   while (1)
14912     switch (TREE_CODE (x))
14913       {
14914       case ADDR_EXPR:
14915       case COMPONENT_REF:
14916       case ARRAY_REF:
14917         x = TREE_OPERAND (x, 0);
14918         break;
14919
14920       case CONSTRUCTOR:
14921         TREE_ADDRESSABLE (x) = 1;
14922         return 1;
14923
14924       case VAR_DECL:
14925       case CONST_DECL:
14926       case PARM_DECL:
14927       case RESULT_DECL:
14928         if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)
14929             && DECL_NONLOCAL (x))
14930           {
14931             if (TREE_PUBLIC (x))
14932               {
14933                 assert ("address of global register var requested" == NULL);
14934                 return 0;
14935               }
14936             assert ("address of register variable requested" == NULL);
14937           }
14938         else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
14939           {
14940             if (TREE_PUBLIC (x))
14941               {
14942                 assert ("address of global register var requested" == NULL);
14943                 return 0;
14944               }
14945             assert ("address of register var requested" == NULL);
14946           }
14947         put_var_into_stack (x);
14948
14949         /* drops in */
14950       case FUNCTION_DECL:
14951         TREE_ADDRESSABLE (x) = 1;
14952 #if 0                           /* poplevel deals with this now.  */
14953         if (DECL_CONTEXT (x) == 0)
14954           TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1;
14955 #endif
14956
14957       default:
14958         return 1;
14959       }
14960 }
14961
14962 /* If DECL has a cleanup, build and return that cleanup here.
14963    This is a callback called by expand_expr.  */
14964
14965 tree
14966 maybe_build_cleanup (decl)
14967      tree decl UNUSED;
14968 {
14969   /* There are no cleanups in Fortran.  */
14970   return NULL_TREE;
14971 }
14972
14973 /* Exit a binding level.
14974    Pop the level off, and restore the state of the identifier-decl mappings
14975    that were in effect when this level was entered.
14976
14977    If KEEP is nonzero, this level had explicit declarations, so
14978    and create a "block" (a BLOCK node) for the level
14979    to record its declarations and subblocks for symbol table output.
14980
14981    If FUNCTIONBODY is nonzero, this level is the body of a function,
14982    so create a block as if KEEP were set and also clear out all
14983    label names.
14984
14985    If REVERSE is nonzero, reverse the order of decls before putting
14986    them into the BLOCK.  */
14987
14988 tree
14989 poplevel (keep, reverse, functionbody)
14990      int keep;
14991      int reverse;
14992      int functionbody;
14993 {
14994   register tree link;
14995   /* The chain of decls was accumulated in reverse order.
14996      Put it into forward order, just for cleanliness.  */
14997   tree decls;
14998   tree subblocks = current_binding_level->blocks;
14999   tree block = 0;
15000   tree decl;
15001   int block_previously_created;
15002
15003   /* Get the decls in the order they were written.
15004      Usually current_binding_level->names is in reverse order.
15005      But parameter decls were previously put in forward order.  */
15006
15007   if (reverse)
15008     current_binding_level->names
15009       = decls = nreverse (current_binding_level->names);
15010   else
15011     decls = current_binding_level->names;
15012
15013   /* Output any nested inline functions within this block
15014      if they weren't already output.  */
15015
15016   for (decl = decls; decl; decl = TREE_CHAIN (decl))
15017     if (TREE_CODE (decl) == FUNCTION_DECL
15018         && ! TREE_ASM_WRITTEN (decl)
15019         && DECL_INITIAL (decl) != 0
15020         && TREE_ADDRESSABLE (decl))
15021       {
15022         /* If this decl was copied from a file-scope decl
15023            on account of a block-scope extern decl,
15024            propagate TREE_ADDRESSABLE to the file-scope decl.
15025
15026            DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
15027            true, since then the decl goes through save_for_inline_copying.  */
15028         if (DECL_ABSTRACT_ORIGIN (decl) != 0
15029             && DECL_ABSTRACT_ORIGIN (decl) != decl)
15030           TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1;
15031         else if (DECL_SAVED_INSNS (decl) != 0)
15032           {
15033             push_function_context ();
15034             output_inline_function (decl);
15035             pop_function_context ();
15036           }
15037       }
15038
15039   /* If there were any declarations or structure tags in that level,
15040      or if this level is a function body,
15041      create a BLOCK to record them for the life of this function.  */
15042
15043   block = 0;
15044   block_previously_created = (current_binding_level->this_block != 0);
15045   if (block_previously_created)
15046     block = current_binding_level->this_block;
15047   else if (keep || functionbody)
15048     block = make_node (BLOCK);
15049   if (block != 0)
15050     {
15051       BLOCK_VARS (block) = decls;
15052       BLOCK_SUBBLOCKS (block) = subblocks;
15053     }
15054
15055   /* In each subblock, record that this is its superior.  */
15056
15057   for (link = subblocks; link; link = TREE_CHAIN (link))
15058     BLOCK_SUPERCONTEXT (link) = block;
15059
15060   /* Clear out the meanings of the local variables of this level.  */
15061
15062   for (link = decls; link; link = TREE_CHAIN (link))
15063     {
15064       if (DECL_NAME (link) != 0)
15065         {
15066           /* If the ident. was used or addressed via a local extern decl,
15067              don't forget that fact.  */
15068           if (DECL_EXTERNAL (link))
15069             {
15070               if (TREE_USED (link))
15071                 TREE_USED (DECL_NAME (link)) = 1;
15072               if (TREE_ADDRESSABLE (link))
15073                 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link)) = 1;
15074             }
15075           IDENTIFIER_LOCAL_VALUE (DECL_NAME (link)) = 0;
15076         }
15077     }
15078
15079   /* If the level being exited is the top level of a function,
15080      check over all the labels, and clear out the current
15081      (function local) meanings of their names.  */
15082
15083   if (functionbody)
15084     {
15085       /* If this is the top level block of a function,
15086          the vars are the function's parameters.
15087          Don't leave them in the BLOCK because they are
15088          found in the FUNCTION_DECL instead.  */
15089
15090       BLOCK_VARS (block) = 0;
15091     }
15092
15093   /* Pop the current level, and free the structure for reuse.  */
15094
15095   {
15096     register struct binding_level *level = current_binding_level;
15097     current_binding_level = current_binding_level->level_chain;
15098
15099     level->level_chain = free_binding_level;
15100     free_binding_level = level;
15101   }
15102
15103   /* Dispose of the block that we just made inside some higher level.  */
15104   if (functionbody
15105       && current_function_decl != error_mark_node)
15106     DECL_INITIAL (current_function_decl) = block;
15107   else if (block)
15108     {
15109       if (!block_previously_created)
15110         current_binding_level->blocks
15111           = chainon (current_binding_level->blocks, block);
15112     }
15113   /* If we did not make a block for the level just exited,
15114      any blocks made for inner levels
15115      (since they cannot be recorded as subblocks in that level)
15116      must be carried forward so they will later become subblocks
15117      of something else.  */
15118   else if (subblocks)
15119     current_binding_level->blocks
15120       = chainon (current_binding_level->blocks, subblocks);
15121
15122   if (block)
15123     TREE_USED (block) = 1;
15124   return block;
15125 }
15126
15127 void
15128 print_lang_decl (file, node, indent)
15129      FILE *file UNUSED;
15130      tree node UNUSED;
15131      int indent UNUSED;
15132 {
15133 }
15134
15135 void
15136 print_lang_identifier (file, node, indent)
15137      FILE *file;
15138      tree node;
15139      int indent;
15140 {
15141   print_node (file, "global", IDENTIFIER_GLOBAL_VALUE (node), indent + 4);
15142   print_node (file, "local", IDENTIFIER_LOCAL_VALUE (node), indent + 4);
15143 }
15144
15145 void
15146 print_lang_statistics ()
15147 {
15148 }
15149
15150 void
15151 print_lang_type (file, node, indent)
15152      FILE *file UNUSED;
15153      tree node UNUSED;
15154      int indent UNUSED;
15155 {
15156 }
15157
15158 /* Record a decl-node X as belonging to the current lexical scope.
15159    Check for errors (such as an incompatible declaration for the same
15160    name already seen in the same scope).
15161
15162    Returns either X or an old decl for the same name.
15163    If an old decl is returned, it may have been smashed
15164    to agree with what X says.  */
15165
15166 tree
15167 pushdecl (x)
15168      tree x;
15169 {
15170   register tree t;
15171   register tree name = DECL_NAME (x);
15172   register struct binding_level *b = current_binding_level;
15173
15174   if ((TREE_CODE (x) == FUNCTION_DECL)
15175       && (DECL_INITIAL (x) == 0)
15176       && DECL_EXTERNAL (x))
15177     DECL_CONTEXT (x) = NULL_TREE;
15178   else
15179     DECL_CONTEXT (x) = current_function_decl;
15180
15181   if (name)
15182     {
15183       if (IDENTIFIER_INVENTED (name))
15184         {
15185 #if BUILT_FOR_270
15186           DECL_ARTIFICIAL (x) = 1;
15187 #endif
15188           DECL_IN_SYSTEM_HEADER (x) = 1;
15189         }
15190
15191       t = lookup_name_current_level (name);
15192
15193       assert ((t == NULL_TREE) || (DECL_CONTEXT (x) == NULL_TREE));
15194
15195       /* Don't push non-parms onto list for parms until we understand
15196          why we're doing this and whether it works.  */
15197
15198       assert ((b == global_binding_level)
15199               || !ffecom_transform_only_dummies_
15200               || TREE_CODE (x) == PARM_DECL);
15201
15202       if ((t != NULL_TREE) && duplicate_decls (x, t))
15203         return t;
15204
15205       /* If we are processing a typedef statement, generate a whole new
15206          ..._TYPE node (which will be just an variant of the existing
15207          ..._TYPE node with identical properties) and then install the
15208          TYPE_DECL node generated to represent the typedef name as the
15209          TYPE_NAME of this brand new (duplicate) ..._TYPE node.
15210
15211          The whole point here is to end up with a situation where each and every
15212          ..._TYPE node the compiler creates will be uniquely associated with
15213          AT MOST one node representing a typedef name. This way, even though
15214          the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
15215          (i.e. "typedef name") nodes very early on, later parts of the
15216          compiler can always do the reverse translation and get back the
15217          corresponding typedef name.  For example, given:
15218
15219          typedef struct S MY_TYPE; MY_TYPE object;
15220
15221          Later parts of the compiler might only know that `object' was of type
15222          `struct S' if it were not for code just below.  With this code
15223          however, later parts of the compiler see something like:
15224
15225          struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
15226
15227          And they can then deduce (from the node for type struct S') that the
15228          original object declaration was:
15229
15230          MY_TYPE object;
15231
15232          Being able to do this is important for proper support of protoize, and
15233          also for generating precise symbolic debugging information which
15234          takes full account of the programmer's (typedef) vocabulary.
15235
15236          Obviously, we don't want to generate a duplicate ..._TYPE node if the
15237          TYPE_DECL node that we are now processing really represents a
15238          standard built-in type.
15239
15240          Since all standard types are effectively declared at line zero in the
15241          source file, we can easily check to see if we are working on a
15242          standard type by checking the current value of lineno.  */
15243
15244       if (TREE_CODE (x) == TYPE_DECL)
15245         {
15246           if (DECL_SOURCE_LINE (x) == 0)
15247             {
15248               if (TYPE_NAME (TREE_TYPE (x)) == 0)
15249                 TYPE_NAME (TREE_TYPE (x)) = x;
15250             }
15251           else if (TREE_TYPE (x) != error_mark_node)
15252             {
15253               tree tt = TREE_TYPE (x);
15254
15255               tt = build_type_copy (tt);
15256               TYPE_NAME (tt) = x;
15257               TREE_TYPE (x) = tt;
15258             }
15259         }
15260
15261       /* This name is new in its binding level. Install the new declaration
15262          and return it.  */
15263       if (b == global_binding_level)
15264         IDENTIFIER_GLOBAL_VALUE (name) = x;
15265       else
15266         IDENTIFIER_LOCAL_VALUE (name) = x;
15267     }
15268
15269   /* Put decls on list in reverse order. We will reverse them later if
15270      necessary.  */
15271   TREE_CHAIN (x) = b->names;
15272   b->names = x;
15273
15274   return x;
15275 }
15276
15277 /* Nonzero if the current level needs to have a BLOCK made.  */
15278
15279 static int
15280 kept_level_p ()
15281 {
15282   tree decl;
15283
15284   for (decl = current_binding_level->names;
15285        decl;
15286        decl = TREE_CHAIN (decl))
15287     {
15288       if (TREE_USED (decl) || TREE_CODE (decl) != VAR_DECL
15289           || (DECL_NAME (decl) && ! DECL_ARTIFICIAL (decl)))
15290         /* Currently, there aren't supposed to be non-artificial names
15291            at other than the top block for a function -- they're
15292            believed to always be temps.  But it's wise to check anyway.  */
15293         return 1;
15294     }
15295   return 0;
15296 }
15297
15298 /* Enter a new binding level.
15299    If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
15300    not for that of tags.  */
15301
15302 void
15303 pushlevel (tag_transparent)
15304      int tag_transparent;
15305 {
15306   register struct binding_level *newlevel = NULL_BINDING_LEVEL;
15307
15308   assert (! tag_transparent);
15309
15310   if (current_binding_level == global_binding_level)
15311     {
15312       named_labels = 0;
15313     }
15314
15315   /* Reuse or create a struct for this binding level.  */
15316
15317   if (free_binding_level)
15318     {
15319       newlevel = free_binding_level;
15320       free_binding_level = free_binding_level->level_chain;
15321     }
15322   else
15323     {
15324       newlevel = make_binding_level ();
15325     }
15326
15327   /* Add this level to the front of the chain (stack) of levels that
15328      are active.  */
15329
15330   *newlevel = clear_binding_level;
15331   newlevel->level_chain = current_binding_level;
15332   current_binding_level = newlevel;
15333 }
15334
15335 /* Set the BLOCK node for the innermost scope
15336    (the one we are currently in).  */
15337
15338 void
15339 set_block (block)
15340      register tree block;
15341 {
15342   current_binding_level->this_block = block;
15343 }
15344
15345 /* ~~gcc/tree.h *should* declare this, because toplev.c references it.  */
15346
15347 /* Can't 'yydebug' a front end not generated by yacc/bison!  */
15348
15349 void
15350 set_yydebug (value)
15351      int value;
15352 {
15353   if (value)
15354     fprintf (stderr, "warning: no yacc/bison-generated output to debug!\n");
15355 }
15356
15357 tree
15358 signed_or_unsigned_type (unsignedp, type)
15359      int unsignedp;
15360      tree type;
15361 {
15362   tree type2;
15363
15364   if (! INTEGRAL_TYPE_P (type))
15365     return type;
15366   if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
15367     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15368   if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
15369     return unsignedp ? unsigned_type_node : integer_type_node;
15370   if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
15371     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15372   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
15373     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15374   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
15375     return (unsignedp ? long_long_unsigned_type_node
15376             : long_long_integer_type_node);
15377
15378   type2 = type_for_size (TYPE_PRECISION (type), unsignedp);
15379   if (type2 == NULL_TREE)
15380     return type;
15381
15382   return type2;
15383 }
15384
15385 tree
15386 signed_type (type)
15387      tree type;
15388 {
15389   tree type1 = TYPE_MAIN_VARIANT (type);
15390   ffeinfoKindtype kt;
15391   tree type2;
15392
15393   if (type1 == unsigned_char_type_node || type1 == char_type_node)
15394     return signed_char_type_node;
15395   if (type1 == unsigned_type_node)
15396     return integer_type_node;
15397   if (type1 == short_unsigned_type_node)
15398     return short_integer_type_node;
15399   if (type1 == long_unsigned_type_node)
15400     return long_integer_type_node;
15401   if (type1 == long_long_unsigned_type_node)
15402     return long_long_integer_type_node;
15403 #if 0   /* gcc/c-* files only */
15404   if (type1 == unsigned_intDI_type_node)
15405     return intDI_type_node;
15406   if (type1 == unsigned_intSI_type_node)
15407     return intSI_type_node;
15408   if (type1 == unsigned_intHI_type_node)
15409     return intHI_type_node;
15410   if (type1 == unsigned_intQI_type_node)
15411     return intQI_type_node;
15412 #endif
15413
15414   type2 = type_for_size (TYPE_PRECISION (type1), 0);
15415   if (type2 != NULL_TREE)
15416     return type2;
15417
15418   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15419     {
15420       type2 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15421
15422       if (type1 == type2)
15423         return ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15424     }
15425
15426   return type;
15427 }
15428
15429 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
15430    or validate its data type for an `if' or `while' statement or ?..: exp.
15431
15432    This preparation consists of taking the ordinary
15433    representation of an expression expr and producing a valid tree
15434    boolean expression describing whether expr is nonzero.  We could
15435    simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
15436    but we optimize comparisons, &&, ||, and !.
15437
15438    The resulting type should always be `integer_type_node'.  */
15439
15440 tree
15441 truthvalue_conversion (expr)
15442      tree expr;
15443 {
15444   if (TREE_CODE (expr) == ERROR_MARK)
15445     return expr;
15446
15447 #if 0 /* This appears to be wrong for C++.  */
15448   /* These really should return error_mark_node after 2.4 is stable.
15449      But not all callers handle ERROR_MARK properly.  */
15450   switch (TREE_CODE (TREE_TYPE (expr)))
15451     {
15452     case RECORD_TYPE:
15453       error ("struct type value used where scalar is required");
15454       return integer_zero_node;
15455
15456     case UNION_TYPE:
15457       error ("union type value used where scalar is required");
15458       return integer_zero_node;
15459
15460     case ARRAY_TYPE:
15461       error ("array type value used where scalar is required");
15462       return integer_zero_node;
15463
15464     default:
15465       break;
15466     }
15467 #endif /* 0 */
15468
15469   switch (TREE_CODE (expr))
15470     {
15471       /* It is simpler and generates better code to have only TRUTH_*_EXPR
15472          or comparison expressions as truth values at this level.  */
15473 #if 0
15474     case COMPONENT_REF:
15475       /* A one-bit unsigned bit-field is already acceptable.  */
15476       if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr, 1)))
15477           && TREE_UNSIGNED (TREE_OPERAND (expr, 1)))
15478         return expr;
15479       break;
15480 #endif
15481
15482     case EQ_EXPR:
15483       /* It is simpler and generates better code to have only TRUTH_*_EXPR
15484          or comparison expressions as truth values at this level.  */
15485 #if 0
15486       if (integer_zerop (TREE_OPERAND (expr, 1)))
15487         return build_unary_op (TRUTH_NOT_EXPR, TREE_OPERAND (expr, 0), 0);
15488 #endif
15489     case NE_EXPR: case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR:
15490     case TRUTH_ANDIF_EXPR:
15491     case TRUTH_ORIF_EXPR:
15492     case TRUTH_AND_EXPR:
15493     case TRUTH_OR_EXPR:
15494     case TRUTH_XOR_EXPR:
15495       TREE_TYPE (expr) = integer_type_node;
15496       return expr;
15497
15498     case ERROR_MARK:
15499       return expr;
15500
15501     case INTEGER_CST:
15502       return integer_zerop (expr) ? integer_zero_node : integer_one_node;
15503
15504     case REAL_CST:
15505       return real_zerop (expr) ? integer_zero_node : integer_one_node;
15506
15507     case ADDR_EXPR:
15508       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 0)))
15509         return build (COMPOUND_EXPR, integer_type_node,
15510                       TREE_OPERAND (expr, 0), integer_one_node);
15511       else
15512         return integer_one_node;
15513
15514     case COMPLEX_EXPR:
15515       return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1))
15516                         ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
15517                        integer_type_node,
15518                        truthvalue_conversion (TREE_OPERAND (expr, 0)),
15519                        truthvalue_conversion (TREE_OPERAND (expr, 1)));
15520
15521     case NEGATE_EXPR:
15522     case ABS_EXPR:
15523     case FLOAT_EXPR:
15524     case FFS_EXPR:
15525       /* These don't change whether an object is non-zero or zero.  */
15526       return truthvalue_conversion (TREE_OPERAND (expr, 0));
15527
15528     case LROTATE_EXPR:
15529     case RROTATE_EXPR:
15530       /* These don't change whether an object is zero or non-zero, but
15531          we can't ignore them if their second arg has side-effects.  */
15532       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)))
15533         return build (COMPOUND_EXPR, integer_type_node, TREE_OPERAND (expr, 1),
15534                       truthvalue_conversion (TREE_OPERAND (expr, 0)));
15535       else
15536         return truthvalue_conversion (TREE_OPERAND (expr, 0));
15537
15538     case COND_EXPR:
15539       /* Distribute the conversion into the arms of a COND_EXPR.  */
15540       return fold (build (COND_EXPR, integer_type_node, TREE_OPERAND (expr, 0),
15541                           truthvalue_conversion (TREE_OPERAND (expr, 1)),
15542                           truthvalue_conversion (TREE_OPERAND (expr, 2))));
15543
15544     case CONVERT_EXPR:
15545       /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
15546          since that affects how `default_conversion' will behave.  */
15547       if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE
15548           || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE)
15549         break;
15550       /* fall through... */
15551     case NOP_EXPR:
15552       /* If this is widening the argument, we can ignore it.  */
15553       if (TYPE_PRECISION (TREE_TYPE (expr))
15554           >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0))))
15555         return truthvalue_conversion (TREE_OPERAND (expr, 0));
15556       break;
15557
15558     case MINUS_EXPR:
15559       /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
15560          this case.  */
15561       if (TARGET_FLOAT_FORMAT == IEEE_FLOAT_FORMAT
15562           && TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE)
15563         break;
15564       /* fall through... */
15565     case BIT_XOR_EXPR:
15566       /* This and MINUS_EXPR can be changed into a comparison of the
15567          two objects.  */
15568       if (TREE_TYPE (TREE_OPERAND (expr, 0))
15569           == TREE_TYPE (TREE_OPERAND (expr, 1)))
15570         return ffecom_2 (NE_EXPR, integer_type_node,
15571                          TREE_OPERAND (expr, 0),
15572                          TREE_OPERAND (expr, 1));
15573       return ffecom_2 (NE_EXPR, integer_type_node,
15574                        TREE_OPERAND (expr, 0),
15575                        fold (build1 (NOP_EXPR,
15576                                      TREE_TYPE (TREE_OPERAND (expr, 0)),
15577                                      TREE_OPERAND (expr, 1))));
15578
15579     case BIT_AND_EXPR:
15580       if (integer_onep (TREE_OPERAND (expr, 1)))
15581         return expr;
15582       break;
15583
15584     case MODIFY_EXPR:
15585 #if 0                           /* No such thing in Fortran. */
15586       if (warn_parentheses && C_EXP_ORIGINAL_CODE (expr) == MODIFY_EXPR)
15587         warning ("suggest parentheses around assignment used as truth value");
15588 #endif
15589       break;
15590
15591     default:
15592       break;
15593     }
15594
15595   if (TREE_CODE (TREE_TYPE (expr)) == COMPLEX_TYPE)
15596     return (ffecom_2
15597             ((TREE_SIDE_EFFECTS (expr)
15598               ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
15599              integer_type_node,
15600              truthvalue_conversion (ffecom_1 (REALPART_EXPR,
15601                                               TREE_TYPE (TREE_TYPE (expr)),
15602                                               expr)),
15603              truthvalue_conversion (ffecom_1 (IMAGPART_EXPR,
15604                                               TREE_TYPE (TREE_TYPE (expr)),
15605                                               expr))));
15606
15607   return ffecom_2 (NE_EXPR, integer_type_node,
15608                    expr,
15609                    convert (TREE_TYPE (expr), integer_zero_node));
15610 }
15611
15612 tree
15613 type_for_mode (mode, unsignedp)
15614      enum machine_mode mode;
15615      int unsignedp;
15616 {
15617   int i;
15618   int j;
15619   tree t;
15620
15621   if (mode == TYPE_MODE (integer_type_node))
15622     return unsignedp ? unsigned_type_node : integer_type_node;
15623
15624   if (mode == TYPE_MODE (signed_char_type_node))
15625     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15626
15627   if (mode == TYPE_MODE (short_integer_type_node))
15628     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15629
15630   if (mode == TYPE_MODE (long_integer_type_node))
15631     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15632
15633   if (mode == TYPE_MODE (long_long_integer_type_node))
15634     return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node;
15635
15636 #if HOST_BITS_PER_WIDE_INT >= 64
15637   if (mode == TYPE_MODE (intTI_type_node))
15638     return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
15639 #endif
15640
15641   if (mode == TYPE_MODE (float_type_node))
15642     return float_type_node;
15643
15644   if (mode == TYPE_MODE (double_type_node))
15645     return double_type_node;
15646
15647   if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
15648     return build_pointer_type (char_type_node);
15649
15650   if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
15651     return build_pointer_type (integer_type_node);
15652
15653   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
15654     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
15655       {
15656         if (((t = ffecom_tree_type[i][j]) != NULL_TREE)
15657             && (mode == TYPE_MODE (t)))
15658           {
15659             if ((i == FFEINFO_basictypeINTEGER) && unsignedp)
15660               return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][j];
15661             else
15662               return t;
15663           }
15664       }
15665
15666   return 0;
15667 }
15668
15669 tree
15670 type_for_size (bits, unsignedp)
15671      unsigned bits;
15672      int unsignedp;
15673 {
15674   ffeinfoKindtype kt;
15675   tree type_node;
15676
15677   if (bits == TYPE_PRECISION (integer_type_node))
15678     return unsignedp ? unsigned_type_node : integer_type_node;
15679
15680   if (bits == TYPE_PRECISION (signed_char_type_node))
15681     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15682
15683   if (bits == TYPE_PRECISION (short_integer_type_node))
15684     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15685
15686   if (bits == TYPE_PRECISION (long_integer_type_node))
15687     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15688
15689   if (bits == TYPE_PRECISION (long_long_integer_type_node))
15690     return (unsignedp ? long_long_unsigned_type_node
15691             : long_long_integer_type_node);
15692
15693   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15694     {
15695       type_node = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15696
15697       if ((type_node != NULL_TREE) && (bits == TYPE_PRECISION (type_node)))
15698         return unsignedp ? ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]
15699           : type_node;
15700     }
15701
15702   return 0;
15703 }
15704
15705 tree
15706 unsigned_type (type)
15707      tree type;
15708 {
15709   tree type1 = TYPE_MAIN_VARIANT (type);
15710   ffeinfoKindtype kt;
15711   tree type2;
15712
15713   if (type1 == signed_char_type_node || type1 == char_type_node)
15714     return unsigned_char_type_node;
15715   if (type1 == integer_type_node)
15716     return unsigned_type_node;
15717   if (type1 == short_integer_type_node)
15718     return short_unsigned_type_node;
15719   if (type1 == long_integer_type_node)
15720     return long_unsigned_type_node;
15721   if (type1 == long_long_integer_type_node)
15722     return long_long_unsigned_type_node;
15723 #if 0   /* gcc/c-* files only */
15724   if (type1 == intDI_type_node)
15725     return unsigned_intDI_type_node;
15726   if (type1 == intSI_type_node)
15727     return unsigned_intSI_type_node;
15728   if (type1 == intHI_type_node)
15729     return unsigned_intHI_type_node;
15730   if (type1 == intQI_type_node)
15731     return unsigned_intQI_type_node;
15732 #endif
15733
15734   type2 = type_for_size (TYPE_PRECISION (type1), 1);
15735   if (type2 != NULL_TREE)
15736     return type2;
15737
15738   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15739     {
15740       type2 = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15741
15742       if (type1 == type2)
15743         return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15744     }
15745
15746   return type;
15747 }
15748
15749 /* Callback routines for garbage collection.  */
15750
15751 int ggc_p = 1;
15752
15753 void
15754 lang_mark_tree (t)
15755      union tree_node *t ATTRIBUTE_UNUSED;
15756 {
15757   if (TREE_CODE (t) == IDENTIFIER_NODE)
15758     {
15759       struct lang_identifier *i = (struct lang_identifier *) t;
15760       ggc_mark_tree (IDENTIFIER_GLOBAL_VALUE (i));
15761       ggc_mark_tree (IDENTIFIER_LOCAL_VALUE (i));
15762       ggc_mark_tree (IDENTIFIER_LABEL_VALUE (i));
15763     }
15764   else if (TYPE_P (t) && TYPE_LANG_SPECIFIC (t))
15765     ggc_mark (TYPE_LANG_SPECIFIC (t));
15766 }
15767
15768 void
15769 lang_mark_false_label_stack (l)
15770      struct label_node *l;
15771 {
15772   /* Fortran doesn't use false_label_stack.  It better be NULL.  */
15773   if (l != NULL)
15774     abort();
15775 }
15776
15777 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
15778 \f
15779 #if FFECOM_GCC_INCLUDE
15780
15781 /* From gcc/cccp.c, the code to handle -I.  */
15782
15783 /* Skip leading "./" from a directory name.
15784    This may yield the empty string, which represents the current directory.  */
15785
15786 static const char *
15787 skip_redundant_dir_prefix (const char *dir)
15788 {
15789   while (dir[0] == '.' && dir[1] == '/')
15790     for (dir += 2; *dir == '/'; dir++)
15791       continue;
15792   if (dir[0] == '.' && !dir[1])
15793     dir++;
15794   return dir;
15795 }
15796
15797 /* The file_name_map structure holds a mapping of file names for a
15798    particular directory.  This mapping is read from the file named
15799    FILE_NAME_MAP_FILE in that directory.  Such a file can be used to
15800    map filenames on a file system with severe filename restrictions,
15801    such as DOS.  The format of the file name map file is just a series
15802    of lines with two tokens on each line.  The first token is the name
15803    to map, and the second token is the actual name to use.  */
15804
15805 struct file_name_map
15806 {
15807   struct file_name_map *map_next;
15808   char *map_from;
15809   char *map_to;
15810 };
15811
15812 #define FILE_NAME_MAP_FILE "header.gcc"
15813
15814 /* Current maximum length of directory names in the search path
15815    for include files.  (Altered as we get more of them.)  */
15816
15817 static int max_include_len = 0;
15818
15819 struct file_name_list
15820   {
15821     struct file_name_list *next;
15822     char *fname;
15823     /* Mapping of file names for this directory.  */
15824     struct file_name_map *name_map;
15825     /* Non-zero if name_map is valid.  */
15826     int got_name_map;
15827   };
15828
15829 static struct file_name_list *include = NULL;   /* First dir to search */
15830 static struct file_name_list *last_include = NULL;      /* Last in chain */
15831
15832 /* I/O buffer structure.
15833    The `fname' field is nonzero for source files and #include files
15834    and for the dummy text used for -D and -U.
15835    It is zero for rescanning results of macro expansion
15836    and for expanding macro arguments.  */
15837 #define INPUT_STACK_MAX 400
15838 static struct file_buf {
15839   const char *fname;
15840   /* Filename specified with #line command.  */
15841   const char *nominal_fname;
15842   /* Record where in the search path this file was found.
15843      For #include_next.  */
15844   struct file_name_list *dir;
15845   ffewhereLine line;
15846   ffewhereColumn column;
15847 } instack[INPUT_STACK_MAX];
15848
15849 static int last_error_tick = 0;    /* Incremented each time we print it.  */
15850 static int input_file_stack_tick = 0;  /* Incremented when status changes.  */
15851
15852 /* Current nesting level of input sources.
15853    `instack[indepth]' is the level currently being read.  */
15854 static int indepth = -1;
15855
15856 typedef struct file_buf FILE_BUF;
15857
15858 typedef unsigned char U_CHAR;
15859
15860 /* table to tell if char can be part of a C identifier. */
15861 U_CHAR is_idchar[256];
15862 /* table to tell if char can be first char of a c identifier. */
15863 U_CHAR is_idstart[256];
15864 /* table to tell if c is horizontal space.  */
15865 U_CHAR is_hor_space[256];
15866 /* table to tell if c is horizontal or vertical space.  */
15867 static U_CHAR is_space[256];
15868
15869 #define SKIP_WHITE_SPACE(p) do { while (is_hor_space[*p]) p++; } while (0)
15870 #define SKIP_ALL_WHITE_SPACE(p) do { while (is_space[*p]) p++; } while (0)
15871
15872 /* Nonzero means -I- has been seen,
15873    so don't look for #include "foo" the source-file directory.  */
15874 static int ignore_srcdir;
15875
15876 #ifndef INCLUDE_LEN_FUDGE
15877 #define INCLUDE_LEN_FUDGE 0
15878 #endif
15879
15880 static void append_include_chain (struct file_name_list *first,
15881                                   struct file_name_list *last);
15882 static FILE *open_include_file (char *filename,
15883                                 struct file_name_list *searchptr);
15884 static void print_containing_files (ffebadSeverity sev);
15885 static const char *skip_redundant_dir_prefix (const char *);
15886 static char *read_filename_string (int ch, FILE *f);
15887 static struct file_name_map *read_name_map (const char *dirname);
15888
15889 /* Append a chain of `struct file_name_list's
15890    to the end of the main include chain.
15891    FIRST is the beginning of the chain to append, and LAST is the end.  */
15892
15893 static void
15894 append_include_chain (first, last)
15895      struct file_name_list *first, *last;
15896 {
15897   struct file_name_list *dir;
15898
15899   if (!first || !last)
15900     return;
15901
15902   if (include == 0)
15903     include = first;
15904   else
15905     last_include->next = first;
15906
15907   for (dir = first; ; dir = dir->next) {
15908     int len = strlen (dir->fname) + INCLUDE_LEN_FUDGE;
15909     if (len > max_include_len)
15910       max_include_len = len;
15911     if (dir == last)
15912       break;
15913   }
15914
15915   last->next = NULL;
15916   last_include = last;
15917 }
15918
15919 /* Try to open include file FILENAME.  SEARCHPTR is the directory
15920    being tried from the include file search path.  This function maps
15921    filenames on file systems based on information read by
15922    read_name_map.  */
15923
15924 static FILE *
15925 open_include_file (filename, searchptr)
15926      char *filename;
15927      struct file_name_list *searchptr;
15928 {
15929   register struct file_name_map *map;
15930   register char *from;
15931   char *p, *dir;
15932
15933   if (searchptr && ! searchptr->got_name_map)
15934     {
15935       searchptr->name_map = read_name_map (searchptr->fname
15936                                            ? searchptr->fname : ".");
15937       searchptr->got_name_map = 1;
15938     }
15939
15940   /* First check the mapping for the directory we are using.  */
15941   if (searchptr && searchptr->name_map)
15942     {
15943       from = filename;
15944       if (searchptr->fname)
15945         from += strlen (searchptr->fname) + 1;
15946       for (map = searchptr->name_map; map; map = map->map_next)
15947         {
15948           if (! strcmp (map->map_from, from))
15949             {
15950               /* Found a match.  */
15951               return fopen (map->map_to, "r");
15952             }
15953         }
15954     }
15955
15956   /* Try to find a mapping file for the particular directory we are
15957      looking in.  Thus #include <sys/types.h> will look up sys/types.h
15958      in /usr/include/header.gcc and look up types.h in
15959      /usr/include/sys/header.gcc.  */
15960   p = rindex (filename, '/');
15961 #ifdef DIR_SEPARATOR
15962   if (! p) p = rindex (filename, DIR_SEPARATOR);
15963   else {
15964     char *tmp = rindex (filename, DIR_SEPARATOR);
15965     if (tmp != NULL && tmp > p) p = tmp;
15966   }
15967 #endif
15968   if (! p)
15969     p = filename;
15970   if (searchptr
15971       && searchptr->fname
15972       && strlen (searchptr->fname) == (size_t) (p - filename)
15973       && ! strncmp (searchptr->fname, filename, (int) (p - filename)))
15974     {
15975       /* FILENAME is in SEARCHPTR, which we've already checked.  */
15976       return fopen (filename, "r");
15977     }
15978
15979   if (p == filename)
15980     {
15981       from = filename;
15982       map = read_name_map (".");
15983     }
15984   else
15985     {
15986       dir = (char *) xmalloc (p - filename + 1);
15987       memcpy (dir, filename, p - filename);
15988       dir[p - filename] = '\0';
15989       from = p + 1;
15990       map = read_name_map (dir);
15991       free (dir);
15992     }
15993   for (; map; map = map->map_next)
15994     if (! strcmp (map->map_from, from))
15995       return fopen (map->map_to, "r");
15996
15997   return fopen (filename, "r");
15998 }
15999
16000 /* Print the file names and line numbers of the #include
16001    commands which led to the current file.  */
16002
16003 static void
16004 print_containing_files (ffebadSeverity sev)
16005 {
16006   FILE_BUF *ip = NULL;
16007   int i;
16008   int first = 1;
16009   const char *str1;
16010   const char *str2;
16011
16012   /* If stack of files hasn't changed since we last printed
16013      this info, don't repeat it.  */
16014   if (last_error_tick == input_file_stack_tick)
16015     return;
16016
16017   for (i = indepth; i >= 0; i--)
16018     if (instack[i].fname != NULL) {
16019       ip = &instack[i];
16020       break;
16021     }
16022
16023   /* Give up if we don't find a source file.  */
16024   if (ip == NULL)
16025     return;
16026
16027   /* Find the other, outer source files.  */
16028   for (i--; i >= 0; i--)
16029     if (instack[i].fname != NULL)
16030       {
16031         ip = &instack[i];
16032         if (first)
16033           {
16034             first = 0;
16035             str1 = "In file included";
16036           }
16037         else
16038           {
16039             str1 = "...          ...";
16040           }
16041
16042         if (i == 1)
16043           str2 = ":";
16044         else
16045           str2 = "";
16046
16047         ffebad_start_msg ("%A from %B at %0%C", sev);
16048         ffebad_here (0, ip->line, ip->column);
16049         ffebad_string (str1);
16050         ffebad_string (ip->nominal_fname);
16051         ffebad_string (str2);
16052         ffebad_finish ();
16053       }
16054
16055   /* Record we have printed the status as of this time.  */
16056   last_error_tick = input_file_stack_tick;
16057 }
16058
16059 /* Read a space delimited string of unlimited length from a stdio
16060    file.  */
16061
16062 static char *
16063 read_filename_string (ch, f)
16064      int ch;
16065      FILE *f;
16066 {
16067   char *alloc, *set;
16068   int len;
16069
16070   len = 20;
16071   set = alloc = xmalloc (len + 1);
16072   if (! is_space[ch])
16073     {
16074       *set++ = ch;
16075       while ((ch = getc (f)) != EOF && ! is_space[ch])
16076         {
16077           if (set - alloc == len)
16078             {
16079               len *= 2;
16080               alloc = xrealloc (alloc, len + 1);
16081               set = alloc + len / 2;
16082             }
16083           *set++ = ch;
16084         }
16085     }
16086   *set = '\0';
16087   ungetc (ch, f);
16088   return alloc;
16089 }
16090
16091 /* Read the file name map file for DIRNAME.  */
16092
16093 static struct file_name_map *
16094 read_name_map (dirname)
16095      const char *dirname;
16096 {
16097   /* This structure holds a linked list of file name maps, one per
16098      directory.  */
16099   struct file_name_map_list
16100     {
16101       struct file_name_map_list *map_list_next;
16102       char *map_list_name;
16103       struct file_name_map *map_list_map;
16104     };
16105   static struct file_name_map_list *map_list;
16106   register struct file_name_map_list *map_list_ptr;
16107   char *name;
16108   FILE *f;
16109   size_t dirlen;
16110   int separator_needed;
16111
16112   dirname = skip_redundant_dir_prefix (dirname);
16113
16114   for (map_list_ptr = map_list; map_list_ptr;
16115        map_list_ptr = map_list_ptr->map_list_next)
16116     if (! strcmp (map_list_ptr->map_list_name, dirname))
16117       return map_list_ptr->map_list_map;
16118
16119   map_list_ptr = ((struct file_name_map_list *)
16120                   xmalloc (sizeof (struct file_name_map_list)));
16121   map_list_ptr->map_list_name = xstrdup (dirname);
16122   map_list_ptr->map_list_map = NULL;
16123
16124   dirlen = strlen (dirname);
16125   separator_needed = dirlen != 0 && dirname[dirlen - 1] != '/';
16126   name = (char *) xmalloc (dirlen + strlen (FILE_NAME_MAP_FILE) + 2);
16127   strcpy (name, dirname);
16128   name[dirlen] = '/';
16129   strcpy (name + dirlen + separator_needed, FILE_NAME_MAP_FILE);
16130   f = fopen (name, "r");
16131   free (name);
16132   if (!f)
16133     map_list_ptr->map_list_map = NULL;
16134   else
16135     {
16136       int ch;
16137
16138       while ((ch = getc (f)) != EOF)
16139         {
16140           char *from, *to;
16141           struct file_name_map *ptr;
16142
16143           if (is_space[ch])
16144             continue;
16145           from = read_filename_string (ch, f);
16146           while ((ch = getc (f)) != EOF && is_hor_space[ch])
16147             ;
16148           to = read_filename_string (ch, f);
16149
16150           ptr = ((struct file_name_map *)
16151                  xmalloc (sizeof (struct file_name_map)));
16152           ptr->map_from = from;
16153
16154           /* Make the real filename absolute.  */
16155           if (*to == '/')
16156             ptr->map_to = to;
16157           else
16158             {
16159               ptr->map_to = xmalloc (dirlen + strlen (to) + 2);
16160               strcpy (ptr->map_to, dirname);
16161               ptr->map_to[dirlen] = '/';
16162               strcpy (ptr->map_to + dirlen + separator_needed, to);
16163               free (to);
16164             }
16165
16166           ptr->map_next = map_list_ptr->map_list_map;
16167           map_list_ptr->map_list_map = ptr;
16168
16169           while ((ch = getc (f)) != '\n')
16170             if (ch == EOF)
16171               break;
16172         }
16173       fclose (f);
16174     }
16175
16176   map_list_ptr->map_list_next = map_list;
16177   map_list = map_list_ptr;
16178
16179   return map_list_ptr->map_list_map;
16180 }
16181
16182 static void
16183 ffecom_file_ (const char *name)
16184 {
16185   FILE_BUF *fp;
16186
16187   /* Do partial setup of input buffer for the sake of generating
16188      early #line directives (when -g is in effect).  */
16189
16190   fp = &instack[++indepth];
16191   memset ((char *) fp, 0, sizeof (FILE_BUF));
16192   if (name == NULL)
16193     name = "";
16194   fp->nominal_fname = fp->fname = name;
16195 }
16196
16197 /* Initialize syntactic classifications of characters.  */
16198
16199 static void
16200 ffecom_initialize_char_syntax_ ()
16201 {
16202   register int i;
16203
16204   /*
16205    * Set up is_idchar and is_idstart tables.  These should be
16206    * faster than saying (is_alpha (c) || c == '_'), etc.
16207    * Set up these things before calling any routines tthat
16208    * refer to them.
16209    */
16210   for (i = 'a'; i <= 'z'; i++) {
16211     is_idchar[i - 'a' + 'A'] = 1;
16212     is_idchar[i] = 1;
16213     is_idstart[i - 'a' + 'A'] = 1;
16214     is_idstart[i] = 1;
16215   }
16216   for (i = '0'; i <= '9'; i++)
16217     is_idchar[i] = 1;
16218   is_idchar['_'] = 1;
16219   is_idstart['_'] = 1;
16220
16221   /* horizontal space table */
16222   is_hor_space[' '] = 1;
16223   is_hor_space['\t'] = 1;
16224   is_hor_space['\v'] = 1;
16225   is_hor_space['\f'] = 1;
16226   is_hor_space['\r'] = 1;
16227
16228   is_space[' '] = 1;
16229   is_space['\t'] = 1;
16230   is_space['\v'] = 1;
16231   is_space['\f'] = 1;
16232   is_space['\n'] = 1;
16233   is_space['\r'] = 1;
16234 }
16235
16236 static void
16237 ffecom_close_include_ (FILE *f)
16238 {
16239   fclose (f);
16240
16241   indepth--;
16242   input_file_stack_tick++;
16243
16244   ffewhere_line_kill (instack[indepth].line);
16245   ffewhere_column_kill (instack[indepth].column);
16246 }
16247
16248 static int
16249 ffecom_decode_include_option_ (char *spec)
16250 {
16251   struct file_name_list *dirtmp;
16252
16253   if (! ignore_srcdir && !strcmp (spec, "-"))
16254     ignore_srcdir = 1;
16255   else
16256     {
16257       dirtmp = (struct file_name_list *)
16258         xmalloc (sizeof (struct file_name_list));
16259       dirtmp->next = 0;         /* New one goes on the end */
16260       if (spec[0] != 0)
16261         dirtmp->fname = spec;
16262       else
16263         fatal ("Directory name must immediately follow -I option with no intervening spaces, as in `-Idir', not `-I dir'");
16264       dirtmp->got_name_map = 0;
16265       append_include_chain (dirtmp, dirtmp);
16266     }
16267   return 1;
16268 }
16269
16270 /* Open INCLUDEd file.  */
16271
16272 static FILE *
16273 ffecom_open_include_ (char *name, ffewhereLine l, ffewhereColumn c)
16274 {
16275   char *fbeg = name;
16276   size_t flen = strlen (fbeg);
16277   struct file_name_list *search_start = include; /* Chain of dirs to search */
16278   struct file_name_list dsp[1]; /* First in chain, if #include "..." */
16279   struct file_name_list *searchptr = 0;
16280   char *fname;          /* Dynamically allocated fname buffer */
16281   FILE *f;
16282   FILE_BUF *fp;
16283
16284   if (flen == 0)
16285     return NULL;
16286
16287   dsp[0].fname = NULL;
16288
16289   /* If -I- was specified, don't search current dir, only spec'd ones. */
16290   if (!ignore_srcdir)
16291     {
16292       for (fp = &instack[indepth]; fp >= instack; fp--)
16293         {
16294           int n;
16295           char *ep;
16296           const char *nam;
16297
16298           if ((nam = fp->nominal_fname) != NULL)
16299             {
16300               /* Found a named file.  Figure out dir of the file,
16301                  and put it in front of the search list.  */
16302               dsp[0].next = search_start;
16303               search_start = dsp;
16304 #ifndef VMS
16305               ep = rindex (nam, '/');
16306 #ifdef DIR_SEPARATOR
16307             if (ep == NULL) ep = rindex (nam, DIR_SEPARATOR);
16308             else {
16309               char *tmp = rindex (nam, DIR_SEPARATOR);
16310               if (tmp != NULL && tmp > ep) ep = tmp;
16311             }
16312 #endif
16313 #else                           /* VMS */
16314               ep = rindex (nam, ']');
16315               if (ep == NULL) ep = rindex (nam, '>');
16316               if (ep == NULL) ep = rindex (nam, ':');
16317               if (ep != NULL) ep++;
16318 #endif                          /* VMS */
16319               if (ep != NULL)
16320                 {
16321                   n = ep - nam;
16322                   dsp[0].fname = (char *) xmalloc (n + 1);
16323                   strncpy (dsp[0].fname, nam, n);
16324                   dsp[0].fname[n] = '\0';
16325                   if (n + INCLUDE_LEN_FUDGE > max_include_len)
16326                     max_include_len = n + INCLUDE_LEN_FUDGE;
16327                 }
16328               else
16329                 dsp[0].fname = NULL; /* Current directory */
16330               dsp[0].got_name_map = 0;
16331               break;
16332             }
16333         }
16334     }
16335
16336   /* Allocate this permanently, because it gets stored in the definitions
16337      of macros.  */
16338   fname = xmalloc (max_include_len + flen + 4);
16339   /* + 2 above for slash and terminating null.  */
16340   /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
16341      for g77 yet).  */
16342
16343   /* If specified file name is absolute, just open it.  */
16344
16345   if (*fbeg == '/'
16346 #ifdef DIR_SEPARATOR
16347       || *fbeg == DIR_SEPARATOR
16348 #endif
16349       )
16350     {
16351       strncpy (fname, (char *) fbeg, flen);
16352       fname[flen] = 0;
16353       f = open_include_file (fname, NULL_PTR);
16354     }
16355   else
16356     {
16357       f = NULL;
16358
16359       /* Search directory path, trying to open the file.
16360          Copy each filename tried into FNAME.  */
16361
16362       for (searchptr = search_start; searchptr; searchptr = searchptr->next)
16363         {
16364           if (searchptr->fname)
16365             {
16366               /* The empty string in a search path is ignored.
16367                  This makes it possible to turn off entirely
16368                  a standard piece of the list.  */
16369               if (searchptr->fname[0] == 0)
16370                 continue;
16371               strcpy (fname, skip_redundant_dir_prefix (searchptr->fname));
16372               if (fname[0] && fname[strlen (fname) - 1] != '/')
16373                 strcat (fname, "/");
16374               fname[strlen (fname) + flen] = 0;
16375             }
16376           else
16377             fname[0] = 0;
16378
16379           strncat (fname, fbeg, flen);
16380 #ifdef VMS
16381           /* Change this 1/2 Unix 1/2 VMS file specification into a
16382              full VMS file specification */
16383           if (searchptr->fname && (searchptr->fname[0] != 0))
16384             {
16385               /* Fix up the filename */
16386               hack_vms_include_specification (fname);
16387             }
16388           else
16389             {
16390               /* This is a normal VMS filespec, so use it unchanged.  */
16391               strncpy (fname, (char *) fbeg, flen);
16392               fname[flen] = 0;
16393 #if 0   /* Not for g77.  */
16394               /* if it's '#include filename', add the missing .h */
16395               if (index (fname, '.') == NULL)
16396                 strcat (fname, ".h");
16397 #endif
16398             }
16399 #endif /* VMS */
16400           f = open_include_file (fname, searchptr);
16401 #ifdef EACCES
16402           if (f == NULL && errno == EACCES)
16403             {
16404               print_containing_files (FFEBAD_severityWARNING);
16405               ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
16406                                 FFEBAD_severityWARNING);
16407               ffebad_string (fname);
16408               ffebad_here (0, l, c);
16409               ffebad_finish ();
16410             }
16411 #endif
16412           if (f != NULL)
16413             break;
16414         }
16415     }
16416
16417   if (f == NULL)
16418     {
16419       /* A file that was not found.  */
16420
16421       strncpy (fname, (char *) fbeg, flen);
16422       fname[flen] = 0;
16423       print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE));
16424       ffebad_start (FFEBAD_OPEN_INCLUDE);
16425       ffebad_here (0, l, c);
16426       ffebad_string (fname);
16427       ffebad_finish ();
16428     }
16429
16430   if (dsp[0].fname != NULL)
16431     free (dsp[0].fname);
16432
16433   if (f == NULL)
16434     return NULL;
16435
16436   if (indepth >= (INPUT_STACK_MAX - 1))
16437     {
16438       print_containing_files (FFEBAD_severityFATAL);
16439       ffebad_start_msg ("At %0, INCLUDE nesting too deep",
16440                         FFEBAD_severityFATAL);
16441       ffebad_string (fname);
16442       ffebad_here (0, l, c);
16443       ffebad_finish ();
16444       return NULL;
16445     }
16446
16447   instack[indepth].line = ffewhere_line_use (l);
16448   instack[indepth].column = ffewhere_column_use (c);
16449
16450   fp = &instack[indepth + 1];
16451   memset ((char *) fp, 0, sizeof (FILE_BUF));
16452   fp->nominal_fname = fp->fname = fname;
16453   fp->dir = searchptr;
16454
16455   indepth++;
16456   input_file_stack_tick++;
16457
16458   return f;
16459 }
16460 #endif  /* FFECOM_GCC_INCLUDE */
16461
16462 /**INDENT* (Do not reformat this comment even with -fca option.)
16463    Data-gathering files: Given the source file listed below, compiled with
16464    f2c I obtained the output file listed after that, and from the output
16465    file I derived the above code.
16466
16467 -------- (begin input file to f2c)
16468         implicit none
16469         character*10 A1,A2
16470         complex C1,C2
16471         integer I1,I2
16472         real R1,R2
16473         double precision D1,D2
16474 C
16475         call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
16476 c /
16477         call fooI(I1/I2)
16478         call fooR(R1/I1)
16479         call fooD(D1/I1)
16480         call fooC(C1/I1)
16481         call fooR(R1/R2)
16482         call fooD(R1/D1)
16483         call fooD(D1/D2)
16484         call fooD(D1/R1)
16485         call fooC(C1/C2)
16486         call fooC(C1/R1)
16487         call fooZ(C1/D1)
16488 c **
16489         call fooI(I1**I2)
16490         call fooR(R1**I1)
16491         call fooD(D1**I1)
16492         call fooC(C1**I1)
16493         call fooR(R1**R2)
16494         call fooD(R1**D1)
16495         call fooD(D1**D2)
16496         call fooD(D1**R1)
16497         call fooC(C1**C2)
16498         call fooC(C1**R1)
16499         call fooZ(C1**D1)
16500 c FFEINTRIN_impABS
16501         call fooR(ABS(R1))
16502 c FFEINTRIN_impACOS
16503         call fooR(ACOS(R1))
16504 c FFEINTRIN_impAIMAG
16505         call fooR(AIMAG(C1))
16506 c FFEINTRIN_impAINT
16507         call fooR(AINT(R1))
16508 c FFEINTRIN_impALOG
16509         call fooR(ALOG(R1))
16510 c FFEINTRIN_impALOG10
16511         call fooR(ALOG10(R1))
16512 c FFEINTRIN_impAMAX0
16513         call fooR(AMAX0(I1,I2))
16514 c FFEINTRIN_impAMAX1
16515         call fooR(AMAX1(R1,R2))
16516 c FFEINTRIN_impAMIN0
16517         call fooR(AMIN0(I1,I2))
16518 c FFEINTRIN_impAMIN1
16519         call fooR(AMIN1(R1,R2))
16520 c FFEINTRIN_impAMOD
16521         call fooR(AMOD(R1,R2))
16522 c FFEINTRIN_impANINT
16523         call fooR(ANINT(R1))
16524 c FFEINTRIN_impASIN
16525         call fooR(ASIN(R1))
16526 c FFEINTRIN_impATAN
16527         call fooR(ATAN(R1))
16528 c FFEINTRIN_impATAN2
16529         call fooR(ATAN2(R1,R2))
16530 c FFEINTRIN_impCABS
16531         call fooR(CABS(C1))
16532 c FFEINTRIN_impCCOS
16533         call fooC(CCOS(C1))
16534 c FFEINTRIN_impCEXP
16535         call fooC(CEXP(C1))
16536 c FFEINTRIN_impCHAR
16537         call fooA(CHAR(I1))
16538 c FFEINTRIN_impCLOG
16539         call fooC(CLOG(C1))
16540 c FFEINTRIN_impCONJG
16541         call fooC(CONJG(C1))
16542 c FFEINTRIN_impCOS
16543         call fooR(COS(R1))
16544 c FFEINTRIN_impCOSH
16545         call fooR(COSH(R1))
16546 c FFEINTRIN_impCSIN
16547         call fooC(CSIN(C1))
16548 c FFEINTRIN_impCSQRT
16549         call fooC(CSQRT(C1))
16550 c FFEINTRIN_impDABS
16551         call fooD(DABS(D1))
16552 c FFEINTRIN_impDACOS
16553         call fooD(DACOS(D1))
16554 c FFEINTRIN_impDASIN
16555         call fooD(DASIN(D1))
16556 c FFEINTRIN_impDATAN
16557         call fooD(DATAN(D1))
16558 c FFEINTRIN_impDATAN2
16559         call fooD(DATAN2(D1,D2))
16560 c FFEINTRIN_impDCOS
16561         call fooD(DCOS(D1))
16562 c FFEINTRIN_impDCOSH
16563         call fooD(DCOSH(D1))
16564 c FFEINTRIN_impDDIM
16565         call fooD(DDIM(D1,D2))
16566 c FFEINTRIN_impDEXP
16567         call fooD(DEXP(D1))
16568 c FFEINTRIN_impDIM
16569         call fooR(DIM(R1,R2))
16570 c FFEINTRIN_impDINT
16571         call fooD(DINT(D1))
16572 c FFEINTRIN_impDLOG
16573         call fooD(DLOG(D1))
16574 c FFEINTRIN_impDLOG10
16575         call fooD(DLOG10(D1))
16576 c FFEINTRIN_impDMAX1
16577         call fooD(DMAX1(D1,D2))
16578 c FFEINTRIN_impDMIN1
16579         call fooD(DMIN1(D1,D2))
16580 c FFEINTRIN_impDMOD
16581         call fooD(DMOD(D1,D2))
16582 c FFEINTRIN_impDNINT
16583         call fooD(DNINT(D1))
16584 c FFEINTRIN_impDPROD
16585         call fooD(DPROD(R1,R2))
16586 c FFEINTRIN_impDSIGN
16587         call fooD(DSIGN(D1,D2))
16588 c FFEINTRIN_impDSIN
16589         call fooD(DSIN(D1))
16590 c FFEINTRIN_impDSINH
16591         call fooD(DSINH(D1))
16592 c FFEINTRIN_impDSQRT
16593         call fooD(DSQRT(D1))
16594 c FFEINTRIN_impDTAN
16595         call fooD(DTAN(D1))
16596 c FFEINTRIN_impDTANH
16597         call fooD(DTANH(D1))
16598 c FFEINTRIN_impEXP
16599         call fooR(EXP(R1))
16600 c FFEINTRIN_impIABS
16601         call fooI(IABS(I1))
16602 c FFEINTRIN_impICHAR
16603         call fooI(ICHAR(A1))
16604 c FFEINTRIN_impIDIM
16605         call fooI(IDIM(I1,I2))
16606 c FFEINTRIN_impIDNINT
16607         call fooI(IDNINT(D1))
16608 c FFEINTRIN_impINDEX
16609         call fooI(INDEX(A1,A2))
16610 c FFEINTRIN_impISIGN
16611         call fooI(ISIGN(I1,I2))
16612 c FFEINTRIN_impLEN
16613         call fooI(LEN(A1))
16614 c FFEINTRIN_impLGE
16615         call fooL(LGE(A1,A2))
16616 c FFEINTRIN_impLGT
16617         call fooL(LGT(A1,A2))
16618 c FFEINTRIN_impLLE
16619         call fooL(LLE(A1,A2))
16620 c FFEINTRIN_impLLT
16621         call fooL(LLT(A1,A2))
16622 c FFEINTRIN_impMAX0
16623         call fooI(MAX0(I1,I2))
16624 c FFEINTRIN_impMAX1
16625         call fooI(MAX1(R1,R2))
16626 c FFEINTRIN_impMIN0
16627         call fooI(MIN0(I1,I2))
16628 c FFEINTRIN_impMIN1
16629         call fooI(MIN1(R1,R2))
16630 c FFEINTRIN_impMOD
16631         call fooI(MOD(I1,I2))
16632 c FFEINTRIN_impNINT
16633         call fooI(NINT(R1))
16634 c FFEINTRIN_impSIGN
16635         call fooR(SIGN(R1,R2))
16636 c FFEINTRIN_impSIN
16637         call fooR(SIN(R1))
16638 c FFEINTRIN_impSINH
16639         call fooR(SINH(R1))
16640 c FFEINTRIN_impSQRT
16641         call fooR(SQRT(R1))
16642 c FFEINTRIN_impTAN
16643         call fooR(TAN(R1))
16644 c FFEINTRIN_impTANH
16645         call fooR(TANH(R1))
16646 c FFEINTRIN_imp_CMPLX_C
16647         call fooC(cmplx(C1,C2))
16648 c FFEINTRIN_imp_CMPLX_D
16649         call fooZ(cmplx(D1,D2))
16650 c FFEINTRIN_imp_CMPLX_I
16651         call fooC(cmplx(I1,I2))
16652 c FFEINTRIN_imp_CMPLX_R
16653         call fooC(cmplx(R1,R2))
16654 c FFEINTRIN_imp_DBLE_C
16655         call fooD(dble(C1))
16656 c FFEINTRIN_imp_DBLE_D
16657         call fooD(dble(D1))
16658 c FFEINTRIN_imp_DBLE_I
16659         call fooD(dble(I1))
16660 c FFEINTRIN_imp_DBLE_R
16661         call fooD(dble(R1))
16662 c FFEINTRIN_imp_INT_C
16663         call fooI(int(C1))
16664 c FFEINTRIN_imp_INT_D
16665         call fooI(int(D1))
16666 c FFEINTRIN_imp_INT_I
16667         call fooI(int(I1))
16668 c FFEINTRIN_imp_INT_R
16669         call fooI(int(R1))
16670 c FFEINTRIN_imp_REAL_C
16671         call fooR(real(C1))
16672 c FFEINTRIN_imp_REAL_D
16673         call fooR(real(D1))
16674 c FFEINTRIN_imp_REAL_I
16675         call fooR(real(I1))
16676 c FFEINTRIN_imp_REAL_R
16677         call fooR(real(R1))
16678 c
16679 c FFEINTRIN_imp_INT_D:
16680 c
16681 c FFEINTRIN_specIDINT
16682         call fooI(IDINT(D1))
16683 c
16684 c FFEINTRIN_imp_INT_R:
16685 c
16686 c FFEINTRIN_specIFIX
16687         call fooI(IFIX(R1))
16688 c FFEINTRIN_specINT
16689         call fooI(INT(R1))
16690 c
16691 c FFEINTRIN_imp_REAL_D:
16692 c
16693 c FFEINTRIN_specSNGL
16694         call fooR(SNGL(D1))
16695 c
16696 c FFEINTRIN_imp_REAL_I:
16697 c
16698 c FFEINTRIN_specFLOAT
16699         call fooR(FLOAT(I1))
16700 c FFEINTRIN_specREAL
16701         call fooR(REAL(I1))
16702 c
16703         end
16704 -------- (end input file to f2c)
16705
16706 -------- (begin output from providing above input file as input to:
16707 --------  `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
16708 --------     -e "s:^#.*$::g"')
16709
16710 //  -- translated by f2c (version 19950223).
16711    You must link the resulting object file with the libraries:
16712         -lf2c -lm   (in that order)
16713 //
16714
16715
16716 // f2c.h  --  Standard Fortran to C header file //
16717
16718 ///  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
16719
16720         - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
16721
16722
16723
16724
16725 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
16726 // we assume short, float are OK //
16727 typedef long int // long int // integer;
16728 typedef char *address;
16729 typedef short int shortint;
16730 typedef float real;
16731 typedef double doublereal;
16732 typedef struct { real r, i; } complex;
16733 typedef struct { doublereal r, i; } doublecomplex;
16734 typedef long int // long int // logical;
16735 typedef short int shortlogical;
16736 typedef char logical1;
16737 typedef char integer1;
16738 // typedef long long longint; // // system-dependent //
16739
16740
16741
16742
16743 // Extern is for use with -E //
16744
16745
16746
16747
16748 // I/O stuff //
16749
16750
16751
16752
16753
16754
16755
16756
16757 typedef long int // int or long int // flag;
16758 typedef long int // int or long int // ftnlen;
16759 typedef long int // int or long int // ftnint;
16760
16761
16762 //external read, write//
16763 typedef struct
16764 {       flag cierr;
16765         ftnint ciunit;
16766         flag ciend;
16767         char *cifmt;
16768         ftnint cirec;
16769 } cilist;
16770
16771 //internal read, write//
16772 typedef struct
16773 {       flag icierr;
16774         char *iciunit;
16775         flag iciend;
16776         char *icifmt;
16777         ftnint icirlen;
16778         ftnint icirnum;
16779 } icilist;
16780
16781 //open//
16782 typedef struct
16783 {       flag oerr;
16784         ftnint ounit;
16785         char *ofnm;
16786         ftnlen ofnmlen;
16787         char *osta;
16788         char *oacc;
16789         char *ofm;
16790         ftnint orl;
16791         char *oblnk;
16792 } olist;
16793
16794 //close//
16795 typedef struct
16796 {       flag cerr;
16797         ftnint cunit;
16798         char *csta;
16799 } cllist;
16800
16801 //rewind, backspace, endfile//
16802 typedef struct
16803 {       flag aerr;
16804         ftnint aunit;
16805 } alist;
16806
16807 // inquire //
16808 typedef struct
16809 {       flag inerr;
16810         ftnint inunit;
16811         char *infile;
16812         ftnlen infilen;
16813         ftnint  *inex;  //parameters in standard's order//
16814         ftnint  *inopen;
16815         ftnint  *innum;
16816         ftnint  *innamed;
16817         char    *inname;
16818         ftnlen  innamlen;
16819         char    *inacc;
16820         ftnlen  inacclen;
16821         char    *inseq;
16822         ftnlen  inseqlen;
16823         char    *indir;
16824         ftnlen  indirlen;
16825         char    *infmt;
16826         ftnlen  infmtlen;
16827         char    *inform;
16828         ftnint  informlen;
16829         char    *inunf;
16830         ftnlen  inunflen;
16831         ftnint  *inrecl;
16832         ftnint  *innrec;
16833         char    *inblank;
16834         ftnlen  inblanklen;
16835 } inlist;
16836
16837
16838
16839 union Multitype {       // for multiple entry points //
16840         integer1 g;
16841         shortint h;
16842         integer i;
16843         // longint j; //
16844         real r;
16845         doublereal d;
16846         complex c;
16847         doublecomplex z;
16848         };
16849
16850 typedef union Multitype Multitype;
16851
16852 typedef long Long;      // No longer used; formerly in Namelist //
16853
16854 struct Vardesc {        // for Namelist //
16855         char *name;
16856         char *addr;
16857         ftnlen *dims;
16858         int  type;
16859         };
16860 typedef struct Vardesc Vardesc;
16861
16862 struct Namelist {
16863         char *name;
16864         Vardesc **vars;
16865         int nvars;
16866         };
16867 typedef struct Namelist Namelist;
16868
16869
16870
16871
16872
16873
16874
16875
16876 // procedure parameter types for -A and -C++ //
16877
16878
16879
16880
16881 typedef int // Unknown procedure type // (*U_fp)();
16882 typedef shortint (*J_fp)();
16883 typedef integer (*I_fp)();
16884 typedef real (*R_fp)();
16885 typedef doublereal (*D_fp)(), (*E_fp)();
16886 typedef // Complex // void  (*C_fp)();
16887 typedef // Double Complex // void  (*Z_fp)();
16888 typedef logical (*L_fp)();
16889 typedef shortlogical (*K_fp)();
16890 typedef // Character // void  (*H_fp)();
16891 typedef // Subroutine // int (*S_fp)();
16892
16893 // E_fp is for real functions when -R is not specified //
16894 typedef void  C_f;      // complex function //
16895 typedef void  H_f;      // character function //
16896 typedef void  Z_f;      // double complex function //
16897 typedef doublereal E_f; // real function with -R not specified //
16898
16899 // undef any lower-case symbols that your C compiler predefines, e.g.: //
16900
16901
16902 // (No such symbols should be defined in a strict ANSI C compiler.
16903    We can avoid trouble with f2c-translated code by using
16904    gcc -ansi [-traditional].) //
16905
16906
16907
16908
16909
16910
16911
16912
16913
16914
16915
16916
16917
16918
16919
16920
16921
16922
16923
16924
16925
16926
16927
16928 // Main program // MAIN__()
16929 {
16930     // System generated locals //
16931     integer i__1;
16932     real r__1, r__2;
16933     doublereal d__1, d__2;
16934     complex q__1;
16935     doublecomplex z__1, z__2, z__3;
16936     logical L__1;
16937     char ch__1[1];
16938
16939     // Builtin functions //
16940     void c_div();
16941     integer pow_ii();
16942     double pow_ri(), pow_di();
16943     void pow_ci();
16944     double pow_dd();
16945     void pow_zz();
16946     double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
16947             asin(), atan(), atan2(), c_abs();
16948     void c_cos(), c_exp(), c_log(), r_cnjg();
16949     double cos(), cosh();
16950     void c_sin(), c_sqrt();
16951     double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
16952             d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
16953     integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
16954     logical l_ge(), l_gt(), l_le(), l_lt();
16955     integer i_nint();
16956     double r_sign();
16957
16958     // Local variables //
16959     extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
16960             fool_(), fooz_(), getem_();
16961     static char a1[10], a2[10];
16962     static complex c1, c2;
16963     static doublereal d1, d2;
16964     static integer i1, i2;
16965     static real r1, r2;
16966
16967
16968     getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
16969 // / //
16970     i__1 = i1 / i2;
16971     fooi_(&i__1);
16972     r__1 = r1 / i1;
16973     foor_(&r__1);
16974     d__1 = d1 / i1;
16975     food_(&d__1);
16976     d__1 = (doublereal) i1;
16977     q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
16978     fooc_(&q__1);
16979     r__1 = r1 / r2;
16980     foor_(&r__1);
16981     d__1 = r1 / d1;
16982     food_(&d__1);
16983     d__1 = d1 / d2;
16984     food_(&d__1);
16985     d__1 = d1 / r1;
16986     food_(&d__1);
16987     c_div(&q__1, &c1, &c2);
16988     fooc_(&q__1);
16989     q__1.r = c1.r / r1, q__1.i = c1.i / r1;
16990     fooc_(&q__1);
16991     z__1.r = c1.r / d1, z__1.i = c1.i / d1;
16992     fooz_(&z__1);
16993 // ** //
16994     i__1 = pow_ii(&i1, &i2);
16995     fooi_(&i__1);
16996     r__1 = pow_ri(&r1, &i1);
16997     foor_(&r__1);
16998     d__1 = pow_di(&d1, &i1);
16999     food_(&d__1);
17000     pow_ci(&q__1, &c1, &i1);
17001     fooc_(&q__1);
17002     d__1 = (doublereal) r1;
17003     d__2 = (doublereal) r2;
17004     r__1 = pow_dd(&d__1, &d__2);
17005     foor_(&r__1);
17006     d__2 = (doublereal) r1;
17007     d__1 = pow_dd(&d__2, &d1);
17008     food_(&d__1);
17009     d__1 = pow_dd(&d1, &d2);
17010     food_(&d__1);
17011     d__2 = (doublereal) r1;
17012     d__1 = pow_dd(&d1, &d__2);
17013     food_(&d__1);
17014     z__2.r = c1.r, z__2.i = c1.i;
17015     z__3.r = c2.r, z__3.i = c2.i;
17016     pow_zz(&z__1, &z__2, &z__3);
17017     q__1.r = z__1.r, q__1.i = z__1.i;
17018     fooc_(&q__1);
17019     z__2.r = c1.r, z__2.i = c1.i;
17020     z__3.r = r1, z__3.i = 0.;
17021     pow_zz(&z__1, &z__2, &z__3);
17022     q__1.r = z__1.r, q__1.i = z__1.i;
17023     fooc_(&q__1);
17024     z__2.r = c1.r, z__2.i = c1.i;
17025     z__3.r = d1, z__3.i = 0.;
17026     pow_zz(&z__1, &z__2, &z__3);
17027     fooz_(&z__1);
17028 // FFEINTRIN_impABS //
17029     r__1 = (doublereal)((  r1  ) >= 0 ? (  r1  ) : -(  r1  ))  ;
17030     foor_(&r__1);
17031 // FFEINTRIN_impACOS //
17032     r__1 = acos(r1);
17033     foor_(&r__1);
17034 // FFEINTRIN_impAIMAG //
17035     r__1 = r_imag(&c1);
17036     foor_(&r__1);
17037 // FFEINTRIN_impAINT //
17038     r__1 = r_int(&r1);
17039     foor_(&r__1);
17040 // FFEINTRIN_impALOG //
17041     r__1 = log(r1);
17042     foor_(&r__1);
17043 // FFEINTRIN_impALOG10 //
17044     r__1 = r_lg10(&r1);
17045     foor_(&r__1);
17046 // FFEINTRIN_impAMAX0 //
17047     r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
17048     foor_(&r__1);
17049 // FFEINTRIN_impAMAX1 //
17050     r__1 = (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
17051     foor_(&r__1);
17052 // FFEINTRIN_impAMIN0 //
17053     r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
17054     foor_(&r__1);
17055 // FFEINTRIN_impAMIN1 //
17056     r__1 = (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
17057     foor_(&r__1);
17058 // FFEINTRIN_impAMOD //
17059     r__1 = r_mod(&r1, &r2);
17060     foor_(&r__1);
17061 // FFEINTRIN_impANINT //
17062     r__1 = r_nint(&r1);
17063     foor_(&r__1);
17064 // FFEINTRIN_impASIN //
17065     r__1 = asin(r1);
17066     foor_(&r__1);
17067 // FFEINTRIN_impATAN //
17068     r__1 = atan(r1);
17069     foor_(&r__1);
17070 // FFEINTRIN_impATAN2 //
17071     r__1 = atan2(r1, r2);
17072     foor_(&r__1);
17073 // FFEINTRIN_impCABS //
17074     r__1 = c_abs(&c1);
17075     foor_(&r__1);
17076 // FFEINTRIN_impCCOS //
17077     c_cos(&q__1, &c1);
17078     fooc_(&q__1);
17079 // FFEINTRIN_impCEXP //
17080     c_exp(&q__1, &c1);
17081     fooc_(&q__1);
17082 // FFEINTRIN_impCHAR //
17083     *(unsigned char *)&ch__1[0] = i1;
17084     fooa_(ch__1, 1L);
17085 // FFEINTRIN_impCLOG //
17086     c_log(&q__1, &c1);
17087     fooc_(&q__1);
17088 // FFEINTRIN_impCONJG //
17089     r_cnjg(&q__1, &c1);
17090     fooc_(&q__1);
17091 // FFEINTRIN_impCOS //
17092     r__1 = cos(r1);
17093     foor_(&r__1);
17094 // FFEINTRIN_impCOSH //
17095     r__1 = cosh(r1);
17096     foor_(&r__1);
17097 // FFEINTRIN_impCSIN //
17098     c_sin(&q__1, &c1);
17099     fooc_(&q__1);
17100 // FFEINTRIN_impCSQRT //
17101     c_sqrt(&q__1, &c1);
17102     fooc_(&q__1);
17103 // FFEINTRIN_impDABS //
17104     d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
17105     food_(&d__1);
17106 // FFEINTRIN_impDACOS //
17107     d__1 = acos(d1);
17108     food_(&d__1);
17109 // FFEINTRIN_impDASIN //
17110     d__1 = asin(d1);
17111     food_(&d__1);
17112 // FFEINTRIN_impDATAN //
17113     d__1 = atan(d1);
17114     food_(&d__1);
17115 // FFEINTRIN_impDATAN2 //
17116     d__1 = atan2(d1, d2);
17117     food_(&d__1);
17118 // FFEINTRIN_impDCOS //
17119     d__1 = cos(d1);
17120     food_(&d__1);
17121 // FFEINTRIN_impDCOSH //
17122     d__1 = cosh(d1);
17123     food_(&d__1);
17124 // FFEINTRIN_impDDIM //
17125     d__1 = d_dim(&d1, &d2);
17126     food_(&d__1);
17127 // FFEINTRIN_impDEXP //
17128     d__1 = exp(d1);
17129     food_(&d__1);
17130 // FFEINTRIN_impDIM //
17131     r__1 = r_dim(&r1, &r2);
17132     foor_(&r__1);
17133 // FFEINTRIN_impDINT //
17134     d__1 = d_int(&d1);
17135     food_(&d__1);
17136 // FFEINTRIN_impDLOG //
17137     d__1 = log(d1);
17138     food_(&d__1);
17139 // FFEINTRIN_impDLOG10 //
17140     d__1 = d_lg10(&d1);
17141     food_(&d__1);
17142 // FFEINTRIN_impDMAX1 //
17143     d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
17144     food_(&d__1);
17145 // FFEINTRIN_impDMIN1 //
17146     d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
17147     food_(&d__1);
17148 // FFEINTRIN_impDMOD //
17149     d__1 = d_mod(&d1, &d2);
17150     food_(&d__1);
17151 // FFEINTRIN_impDNINT //
17152     d__1 = d_nint(&d1);
17153     food_(&d__1);
17154 // FFEINTRIN_impDPROD //
17155     d__1 = (doublereal) r1 * r2;
17156     food_(&d__1);
17157 // FFEINTRIN_impDSIGN //
17158     d__1 = d_sign(&d1, &d2);
17159     food_(&d__1);
17160 // FFEINTRIN_impDSIN //
17161     d__1 = sin(d1);
17162     food_(&d__1);
17163 // FFEINTRIN_impDSINH //
17164     d__1 = sinh(d1);
17165     food_(&d__1);
17166 // FFEINTRIN_impDSQRT //
17167     d__1 = sqrt(d1);
17168     food_(&d__1);
17169 // FFEINTRIN_impDTAN //
17170     d__1 = tan(d1);
17171     food_(&d__1);
17172 // FFEINTRIN_impDTANH //
17173     d__1 = tanh(d1);
17174     food_(&d__1);
17175 // FFEINTRIN_impEXP //
17176     r__1 = exp(r1);
17177     foor_(&r__1);
17178 // FFEINTRIN_impIABS //
17179     i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
17180     fooi_(&i__1);
17181 // FFEINTRIN_impICHAR //
17182     i__1 = *(unsigned char *)a1;
17183     fooi_(&i__1);
17184 // FFEINTRIN_impIDIM //
17185     i__1 = i_dim(&i1, &i2);
17186     fooi_(&i__1);
17187 // FFEINTRIN_impIDNINT //
17188     i__1 = i_dnnt(&d1);
17189     fooi_(&i__1);
17190 // FFEINTRIN_impINDEX //
17191     i__1 = i_indx(a1, a2, 10L, 10L);
17192     fooi_(&i__1);
17193 // FFEINTRIN_impISIGN //
17194     i__1 = i_sign(&i1, &i2);
17195     fooi_(&i__1);
17196 // FFEINTRIN_impLEN //
17197     i__1 = i_len(a1, 10L);
17198     fooi_(&i__1);
17199 // FFEINTRIN_impLGE //
17200     L__1 = l_ge(a1, a2, 10L, 10L);
17201     fool_(&L__1);
17202 // FFEINTRIN_impLGT //
17203     L__1 = l_gt(a1, a2, 10L, 10L);
17204     fool_(&L__1);
17205 // FFEINTRIN_impLLE //
17206     L__1 = l_le(a1, a2, 10L, 10L);
17207     fool_(&L__1);
17208 // FFEINTRIN_impLLT //
17209     L__1 = l_lt(a1, a2, 10L, 10L);
17210     fool_(&L__1);
17211 // FFEINTRIN_impMAX0 //
17212     i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
17213     fooi_(&i__1);
17214 // FFEINTRIN_impMAX1 //
17215     i__1 = (integer) (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
17216     fooi_(&i__1);
17217 // FFEINTRIN_impMIN0 //
17218     i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
17219     fooi_(&i__1);
17220 // FFEINTRIN_impMIN1 //
17221     i__1 = (integer) (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
17222     fooi_(&i__1);
17223 // FFEINTRIN_impMOD //
17224     i__1 = i1 % i2;
17225     fooi_(&i__1);
17226 // FFEINTRIN_impNINT //
17227     i__1 = i_nint(&r1);
17228     fooi_(&i__1);
17229 // FFEINTRIN_impSIGN //
17230     r__1 = r_sign(&r1, &r2);
17231     foor_(&r__1);
17232 // FFEINTRIN_impSIN //
17233     r__1 = sin(r1);
17234     foor_(&r__1);
17235 // FFEINTRIN_impSINH //
17236     r__1 = sinh(r1);
17237     foor_(&r__1);
17238 // FFEINTRIN_impSQRT //
17239     r__1 = sqrt(r1);
17240     foor_(&r__1);
17241 // FFEINTRIN_impTAN //
17242     r__1 = tan(r1);
17243     foor_(&r__1);
17244 // FFEINTRIN_impTANH //
17245     r__1 = tanh(r1);
17246     foor_(&r__1);
17247 // FFEINTRIN_imp_CMPLX_C //
17248     r__1 = c1.r;
17249     r__2 = c2.r;
17250     q__1.r = r__1, q__1.i = r__2;
17251     fooc_(&q__1);
17252 // FFEINTRIN_imp_CMPLX_D //
17253     z__1.r = d1, z__1.i = d2;
17254     fooz_(&z__1);
17255 // FFEINTRIN_imp_CMPLX_I //
17256     r__1 = (real) i1;
17257     r__2 = (real) i2;
17258     q__1.r = r__1, q__1.i = r__2;
17259     fooc_(&q__1);
17260 // FFEINTRIN_imp_CMPLX_R //
17261     q__1.r = r1, q__1.i = r2;
17262     fooc_(&q__1);
17263 // FFEINTRIN_imp_DBLE_C //
17264     d__1 = (doublereal) c1.r;
17265     food_(&d__1);
17266 // FFEINTRIN_imp_DBLE_D //
17267     d__1 = d1;
17268     food_(&d__1);
17269 // FFEINTRIN_imp_DBLE_I //
17270     d__1 = (doublereal) i1;
17271     food_(&d__1);
17272 // FFEINTRIN_imp_DBLE_R //
17273     d__1 = (doublereal) r1;
17274     food_(&d__1);
17275 // FFEINTRIN_imp_INT_C //
17276     i__1 = (integer) c1.r;
17277     fooi_(&i__1);
17278 // FFEINTRIN_imp_INT_D //
17279     i__1 = (integer) d1;
17280     fooi_(&i__1);
17281 // FFEINTRIN_imp_INT_I //
17282     i__1 = i1;
17283     fooi_(&i__1);
17284 // FFEINTRIN_imp_INT_R //
17285     i__1 = (integer) r1;
17286     fooi_(&i__1);
17287 // FFEINTRIN_imp_REAL_C //
17288     r__1 = c1.r;
17289     foor_(&r__1);
17290 // FFEINTRIN_imp_REAL_D //
17291     r__1 = (real) d1;
17292     foor_(&r__1);
17293 // FFEINTRIN_imp_REAL_I //
17294     r__1 = (real) i1;
17295     foor_(&r__1);
17296 // FFEINTRIN_imp_REAL_R //
17297     r__1 = r1;
17298     foor_(&r__1);
17299
17300 // FFEINTRIN_imp_INT_D: //
17301
17302 // FFEINTRIN_specIDINT //
17303     i__1 = (integer) d1;
17304     fooi_(&i__1);
17305
17306 // FFEINTRIN_imp_INT_R: //
17307
17308 // FFEINTRIN_specIFIX //
17309     i__1 = (integer) r1;
17310     fooi_(&i__1);
17311 // FFEINTRIN_specINT //
17312     i__1 = (integer) r1;
17313     fooi_(&i__1);
17314
17315 // FFEINTRIN_imp_REAL_D: //
17316
17317 // FFEINTRIN_specSNGL //
17318     r__1 = (real) d1;
17319     foor_(&r__1);
17320
17321 // FFEINTRIN_imp_REAL_I: //
17322
17323 // FFEINTRIN_specFLOAT //
17324     r__1 = (real) i1;
17325     foor_(&r__1);
17326 // FFEINTRIN_specREAL //
17327     r__1 = (real) i1;
17328     foor_(&r__1);
17329
17330 } // MAIN__ //
17331
17332 -------- (end output file from f2c)
17333
17334 */