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 /* ~~gcc/tree.h *should* declare this, because toplev.c and dwarfout.c
 221    reference it.  */
 222
 223 const char * const language_string = "GNU F77";
 224
 225 /* Stream for reading from the input file.  */
 226 FILE *finput;
 227
 228 /* These definitions parallel those in c-decl.c so that code from that
 229    module can be used pretty much as is.  Much of these defs aren't
 230    otherwise used, i.e. by g77 code per se, except some of them are used
 231    to build some of them that are.  The ones that are global (i.e. not
 232    "static") are those that ste.c and such might use (directly
 233    or by using com macros that reference them in their definitions).  */
 234
 235 tree string_type_node;
 236
 237 /* The rest of these are inventions for g77, though there might be
 238    similar things in the C front end.  As they are found, these
 239    inventions should be renamed to be canonical.  Note that only
 240    the ones currently required to be global are so.  */
 241
 242 static tree ffecom_tree_fun_type_void;
 243
 244 tree ffecom_integer_type_node;  /* Abbrev for _tree_type[blah][blah]. */
 245 tree ffecom_integer_zero_node;  /* Like *_*_* with g77's integer type. */
 246 tree ffecom_integer_one_node;   /* " */
 247 tree ffecom_tree_type[FFEINFO_basictype][FFEINFO_kindtype];
 248
 249 /* _fun_type things are the f2c-specific versions.  For -fno-f2c,
 250    just use build_function_type and build_pointer_type on the
 251    appropriate _tree_type array element.  */
 252
 253 static tree ffecom_tree_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
 254 static tree ffecom_tree_ptr_to_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
 255 static tree ffecom_tree_subr_type;
 256 static tree ffecom_tree_ptr_to_subr_type;
 257 static tree ffecom_tree_blockdata_type;
 258
 259 static tree ffecom_tree_xargc_;
 260
 261 ffecomSymbol ffecom_symbol_null_
 262 =
 263 {
 264   NULL_TREE,
 265   NULL_TREE,
 266   NULL_TREE,
 267   NULL_TREE,
 268   false
 269 };
 270 ffeinfoKindtype ffecom_pointer_kind_ = FFEINFO_basictypeNONE;
 271 ffeinfoKindtype ffecom_label_kind_ = FFEINFO_basictypeNONE;
 272
 273 int ffecom_f2c_typecode_[FFEINFO_basictype][FFEINFO_kindtype];
 274 tree ffecom_f2c_integer_type_node;
 275 tree ffecom_f2c_ptr_to_integer_type_node;
 276 tree ffecom_f2c_address_type_node;
 277 tree ffecom_f2c_real_type_node;
 278 tree ffecom_f2c_ptr_to_real_type_node;
 279 tree ffecom_f2c_doublereal_type_node;
 280 tree ffecom_f2c_complex_type_node;
 281 tree ffecom_f2c_doublecomplex_type_node;
 282 tree ffecom_f2c_longint_type_node;
 283 tree ffecom_f2c_logical_type_node;
 284 tree ffecom_f2c_flag_type_node;
 285 tree ffecom_f2c_ftnlen_type_node;
 286 tree ffecom_f2c_ftnlen_zero_node;
 287 tree ffecom_f2c_ftnlen_one_node;
 288 tree ffecom_f2c_ftnlen_two_node;
 289 tree ffecom_f2c_ptr_to_ftnlen_type_node;
 290 tree ffecom_f2c_ftnint_type_node;
 291 tree ffecom_f2c_ptr_to_ftnint_type_node;
 292 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 293
 294 /* Simple definitions and enumerations. */
 295
 296 #ifndef FFECOM_sizeMAXSTACKITEM
 297 #define FFECOM_sizeMAXSTACKITEM 32*1024 /* Keep user-declared things
 298                                            larger than this # bytes
 299                                            off stack if possible. */
 300 #endif
 301
 302 /* For systems that have large enough stacks, they should define
 303    this to 0, and here, for ease of use later on, we just undefine
 304    it if it is 0.  */
 305
 306 #if FFECOM_sizeMAXSTACKITEM == 0
 307 #undef FFECOM_sizeMAXSTACKITEM
 308 #endif
 309
 310 typedef enum
 311   {
 312     FFECOM_rttypeVOID_,
 313     FFECOM_rttypeVOIDSTAR_,     /* C's `void *' type. */
 314     FFECOM_rttypeFTNINT_,       /* f2c's `ftnint' type. */
 315     FFECOM_rttypeINTEGER_,      /* f2c's `integer' type. */
 316     FFECOM_rttypeLONGINT_,      /* f2c's `longint' type. */
 317     FFECOM_rttypeLOGICAL_,      /* f2c's `logical' type. */
 318     FFECOM_rttypeREAL_F2C_,     /* f2c's `real' returned as `double'. */
 319     FFECOM_rttypeREAL_GNU_,     /* `real' returned as such. */
 320     FFECOM_rttypeCOMPLEX_F2C_,  /* f2c's `complex' returned via 1st arg. */
 321     FFECOM_rttypeCOMPLEX_GNU_,  /* f2c's `complex' returned directly. */
 322     FFECOM_rttypeDOUBLE_,       /* C's `double' type. */
 323     FFECOM_rttypeDOUBLEREAL_,   /* f2c's `doublereal' type. */
 324     FFECOM_rttypeDBLCMPLX_F2C_, /* f2c's `doublecomplex' returned via 1st arg. */
 325     FFECOM_rttypeDBLCMPLX_GNU_, /* f2c's `doublecomplex' returned directly. */
 326     FFECOM_rttypeCHARACTER_,    /* f2c `char *'/`ftnlen' pair. */
 327     FFECOM_rttype_
 328   } ffecomRttype_;
 329
 330 /* Internal typedefs. */
 331
 332 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 333 typedef struct _ffecom_concat_list_ ffecomConcatList_;
 334 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 335
 336 /* Private include files. */
 337
 338
 339 /* Internal structure definitions. */
 340
 341 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 342 struct _ffecom_concat_list_
 343   {
 344     ffebld *exprs;
 345     int count;
 346     int max;
 347     ffetargetCharacterSize minlen;
 348     ffetargetCharacterSize maxlen;
 349   };
 350 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 351
 352 /* Static functions (internal). */
 353
 354 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 355 static tree ffecom_arglist_expr_ (const char *argstring, ffebld args);
 356 static tree ffecom_widest_expr_type_ (ffebld list);
 357 static bool ffecom_overlap_ (tree dest_decl, tree dest_offset,
 358                              tree dest_size, tree source_tree,
 359                              ffebld source, bool scalar_arg);
 360 static bool ffecom_args_overlapping_ (tree dest_tree, ffebld dest,
 361                                       tree args, tree callee_commons,
 362                                       bool scalar_args);
 363 static tree ffecom_build_f2c_string_ (int i, const char *s);
 364 static tree ffecom_call_ (tree fn, ffeinfoKindtype kt,
 365                           bool is_f2c_complex, tree type,
 366                           tree args, tree dest_tree,
 367                           ffebld dest, bool *dest_used,
 368                           tree callee_commons, bool scalar_args, tree hook);
 369 static tree ffecom_call_binop_ (tree fn, ffeinfoKindtype kt,
 370                                 bool is_f2c_complex, tree type,
 371                                 ffebld left, ffebld right,
 372                                 tree dest_tree, ffebld dest,
 373                                 bool *dest_used, tree callee_commons,
 374                                 bool scalar_args, tree hook);
 375 static void ffecom_char_args_x_ (tree *xitem, tree *length,
 376                                  ffebld expr, bool with_null);
 377 static tree ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy);
 378 static tree ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s);
 379 static ffecomConcatList_
 380   ffecom_concat_list_gather_ (ffecomConcatList_ catlist,
 381                               ffebld expr,
 382                               ffetargetCharacterSize max);
 383 static void ffecom_concat_list_kill_ (ffecomConcatList_ catlist);
 384 static ffecomConcatList_ ffecom_concat_list_new_ (ffebld expr,
 385                                                 ffetargetCharacterSize max);
 386 static void ffecom_debug_kludge_ (tree aggr, const char *aggr_type,
 387                                   ffesymbol member, tree member_type,
 388                                   ffetargetOffset offset);
 389 static void ffecom_do_entry_ (ffesymbol fn, int entrynum);
 390 static tree ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
 391                           bool *dest_used, bool assignp, bool widenp);
 392 static tree ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
 393                                     ffebld dest, bool *dest_used);
 394 static tree ffecom_expr_power_integer_ (ffebld expr);
 395 static void ffecom_expr_transform_ (ffebld expr);
 396 static void ffecom_f2c_make_type_ (tree *type, int tcode, const char *name);
 397 static void ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
 398                                       int code);
 399 static ffeglobal ffecom_finish_global_ (ffeglobal global);
 400 static ffesymbol ffecom_finish_symbol_transform_ (ffesymbol s);
 401 static tree ffecom_get_appended_identifier_ (char us, const char *text);
 402 static tree ffecom_get_external_identifier_ (ffesymbol s);
 403 static tree ffecom_get_identifier_ (const char *text);
 404 static tree ffecom_gen_sfuncdef_ (ffesymbol s,
 405                                   ffeinfoBasictype bt,
 406                                   ffeinfoKindtype kt);
 407 static const char *ffecom_gfrt_args_ (ffecomGfrt ix);
 408 static tree ffecom_gfrt_tree_ (ffecomGfrt ix);
 409 static tree ffecom_init_zero_ (tree decl);
 410 static tree ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
 411                                      tree *maybe_tree);
 412 static tree ffecom_intrinsic_len_ (ffebld expr);
 413 static void ffecom_let_char_ (tree dest_tree,
 414                               tree dest_length,
 415                               ffetargetCharacterSize dest_size,
 416                               ffebld source);
 417 static void ffecom_make_gfrt_ (ffecomGfrt ix);
 418 static void ffecom_member_phase1_ (ffestorag mst, ffestorag st);
 419 static void ffecom_member_phase2_ (ffestorag mst, ffestorag st);
 420 static void ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size,
 421                                       ffebld source);
 422 static void ffecom_push_dummy_decls_ (ffebld dumlist,
 423                                       bool stmtfunc);
 424 static void ffecom_start_progunit_ (void);
 425 static ffesymbol ffecom_sym_transform_ (ffesymbol s);
 426 static ffesymbol ffecom_sym_transform_assign_ (ffesymbol s);
 427 static void ffecom_transform_common_ (ffesymbol s);
 428 static void ffecom_transform_equiv_ (ffestorag st);
 429 static tree ffecom_transform_namelist_ (ffesymbol s);
 430 static void ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
 431                                        tree t);
 432 static void ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
 433                                        tree *size, tree tree);
 434 static tree ffecom_tree_divide_ (tree tree_type, tree left, tree right,
 435                                  tree dest_tree, ffebld dest,
 436                                  bool *dest_used, tree hook);
 437 static tree ffecom_type_localvar_ (ffesymbol s,
 438                                    ffeinfoBasictype bt,
 439                                    ffeinfoKindtype kt);
 440 static tree ffecom_type_namelist_ (void);
 441 static tree ffecom_type_vardesc_ (void);
 442 static tree ffecom_vardesc_ (ffebld expr);
 443 static tree ffecom_vardesc_array_ (ffesymbol s);
 444 static tree ffecom_vardesc_dims_ (ffesymbol s);
 445 static tree ffecom_convert_narrow_ (tree type, tree expr);
 446 static tree ffecom_convert_widen_ (tree type, tree expr);
 447 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 448
 449 /* These are static functions that parallel those found in the C front
 450    end and thus have the same names.  */
 451
 452 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 453 static tree bison_rule_compstmt_ (void);
 454 static void bison_rule_pushlevel_ (void);
 455 static void delete_block (tree block);
 456 static int duplicate_decls (tree newdecl, tree olddecl);
 457 static void finish_decl (tree decl, tree init, bool is_top_level);
 458 static void finish_function (int nested);
 459 static const char *lang_printable_name (tree decl, int v);
 460 static tree lookup_name_current_level (tree name);
 461 static struct binding_level *make_binding_level (void);
 462 static void pop_f_function_context (void);
 463 static void push_f_function_context (void);
 464 static void push_parm_decl (tree parm);
 465 static tree pushdecl_top_level (tree decl);
 466 static int kept_level_p (void);
 467 static tree storedecls (tree decls);
 468 static void store_parm_decls (int is_main_program);
 469 static tree start_decl (tree decl, bool is_top_level);
 470 static void start_function (tree name, tree type, int nested, int public);
 471 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 472 #if FFECOM_GCC_INCLUDE
 473 static void ffecom_file_ (const char *name);
 474 static void ffecom_initialize_char_syntax_ (void);
 475 static void ffecom_close_include_ (FILE *f);
 476 static int ffecom_decode_include_option_ (char *spec);
 477 static FILE *ffecom_open_include_ (char *name, ffewhereLine l,
 478                                    ffewhereColumn c);
 479 #endif  /* FFECOM_GCC_INCLUDE */
 480
 481 /* Static objects accessed by functions in this module. */
 482
 483 static ffesymbol ffecom_primary_entry_ = NULL;
 484 static ffesymbol ffecom_nested_entry_ = NULL;
 485 static ffeinfoKind ffecom_primary_entry_kind_;
 486 static bool ffecom_primary_entry_is_proc_;
 487 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 488 static tree ffecom_outer_function_decl_;
 489 static tree ffecom_previous_function_decl_;
 490 static tree ffecom_which_entrypoint_decl_;
 491 static tree ffecom_float_zero_ = NULL_TREE;
 492 static tree ffecom_float_half_ = NULL_TREE;
 493 static tree ffecom_double_zero_ = NULL_TREE;
 494 static tree ffecom_double_half_ = NULL_TREE;
 495 static tree ffecom_func_result_;/* For functions. */
 496 static tree ffecom_func_length_;/* For CHARACTER fns. */
 497 static ffebld ffecom_list_blockdata_;
 498 static ffebld ffecom_list_common_;
 499 static ffebld ffecom_master_arglist_;
 500 static ffeinfoBasictype ffecom_master_bt_;
 501 static ffeinfoKindtype ffecom_master_kt_;
 502 static ffetargetCharacterSize ffecom_master_size_;
 503 static int ffecom_num_fns_ = 0;
 504 static int ffecom_num_entrypoints_ = 0;
 505 static bool ffecom_is_altreturning_ = FALSE;
 506 static tree ffecom_multi_type_node_;
 507 static tree ffecom_multi_retval_;
 508 static tree
 509   ffecom_multi_fields_[FFEINFO_basictype][FFEINFO_kindtype];
 510 static bool ffecom_member_namelisted_;  /* _member_phase1_ namelisted? */
 511 static bool ffecom_doing_entry_ = FALSE;
 512 static bool ffecom_transform_only_dummies_ = FALSE;
 513 static int ffecom_typesize_pointer_;
 514 static int ffecom_typesize_integer1_;
 515
 516 /* Holds pointer-to-function expressions.  */
 517
 518 static tree ffecom_gfrt_[FFECOM_gfrt]
 519 =
 520 {
 521 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) NULL_TREE,
 522 #include "com-rt.def"
 523 #undef DEFGFRT
 524 };
 525
 526 /* Holds the external names of the functions.  */
 527
 528 static const char *ffecom_gfrt_name_[FFECOM_gfrt]
 529 =
 530 {
 531 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) NAME,
 532 #include "com-rt.def"
 533 #undef DEFGFRT
 534 };
 535
 536 /* Whether the function returns.  */
 537
 538 static bool ffecom_gfrt_volatile_[FFECOM_gfrt]
 539 =
 540 {
 541 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) VOLATILE,
 542 #include "com-rt.def"
 543 #undef DEFGFRT
 544 };
 545
 546 /* Whether the function returns type complex.  */
 547
 548 static bool ffecom_gfrt_complex_[FFECOM_gfrt]
 549 =
 550 {
 551 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) COMPLEX,
 552 #include "com-rt.def"
 553 #undef DEFGFRT
 554 };
 555
 556 /* Type code for the function return value.  */
 557
 558 static ffecomRttype_ ffecom_gfrt_type_[FFECOM_gfrt]
 559 =
 560 {
 561 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) TYPE,
 562 #include "com-rt.def"
 563 #undef DEFGFRT
 564 };
 565
 566 /* String of codes for the function's arguments.  */
 567
 568 static const char *ffecom_gfrt_argstring_[FFECOM_gfrt]
 569 =
 570 {
 571 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) ARGS,
 572 #include "com-rt.def"
 573 #undef DEFGFRT
 574 };
 575 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 576
 577 /* Internal macros. */
 578
 579 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 580
 581 /* We let tm.h override the types used here, to handle trivial differences
 582    such as the choice of unsigned int or long unsigned int for size_t.
 583    When machines start needing nontrivial differences in the size type,
 584    it would be best to do something here to figure out automatically
 585    from other information what type to use.  */
 586
 587 #ifndef SIZE_TYPE
 588 #define SIZE_TYPE "long unsigned int"
 589 #endif
 590
 591 #define ffecom_concat_list_count_(catlist) ((catlist).count)
 592 #define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)])
 593 #define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen)
 594 #define ffecom_concat_list_minlen_(catlist) ((catlist).minlen)
 595
 596 #define ffecom_char_args_(i,l,e) ffecom_char_args_x_((i),(l),(e),FALSE)
 597 #define ffecom_char_args_with_null_(i,l,e) ffecom_char_args_x_((i),(l),(e),TRUE)
 598
 599 /* For each binding contour we allocate a binding_level structure
 600  * which records the names defined in that contour.
 601  * Contours include:
 602  *  0) the global one
 603  *  1) one for each function definition,
 604  *     where internal declarations of the parameters appear.
 605  *
 606  * The current meaning of a name can be found by searching the levels from
 607  * the current one out to the global one.
 608  */
 609
 610 /* Note that the information in the `names' component of the global contour
 611    is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers.  */
 612
 613 struct binding_level
 614   {
 615     /* A chain of _DECL nodes for all variables, constants, functions,
 616        and typedef types.  These are in the reverse of the order supplied.
 617      */
 618     tree names;
 619
 620     /* For each level (except not the global one),
 621        a chain of BLOCK nodes for all the levels
 622        that were entered and exited one level down.  */
 623     tree blocks;
 624
 625     /* The BLOCK node for this level, if one has been preallocated.
 626        If 0, the BLOCK is allocated (if needed) when the level is popped.  */
 627     tree this_block;
 628
 629     /* The binding level which this one is contained in (inherits from).  */
 630     struct binding_level *level_chain;
 631
 632     /* 0: no ffecom_prepare_* functions called at this level yet;
 633        1: ffecom_prepare* functions called, except not ffecom_prepare_end;
 634        2: ffecom_prepare_end called.  */
 635     int prep_state;
 636   };
 637
 638 #define NULL_BINDING_LEVEL (struct binding_level *) NULL
 639
 640 /* The binding level currently in effect.  */
 641
 642 static struct binding_level *current_binding_level;
 643
 644 /* A chain of binding_level structures awaiting reuse.  */
 645
 646 static struct binding_level *free_binding_level;
 647
 648 /* The outermost binding level, for names of file scope.
 649    This is created when the compiler is started and exists
 650    through the entire run.  */
 651
 652 static struct binding_level *global_binding_level;
 653
 654 /* Binding level structures are initialized by copying this one.  */
 655
 656 static struct binding_level clear_binding_level
 657 =
 658 {NULL, NULL, NULL, NULL_BINDING_LEVEL, 0};
 659
 660 /* Language-dependent contents of an identifier.  */
 661
 662 struct lang_identifier
 663   {
 664     struct tree_identifier ignore;
 665     tree global_value, local_value, label_value;
 666     bool invented;
 667   };
 668
 669 /* Macros for access to language-specific slots in an identifier.  */
 670 /* Each of these slots contains a DECL node or null.  */
 671
 672 /* This represents the value which the identifier has in the
 673    file-scope namespace.  */
 674 #define IDENTIFIER_GLOBAL_VALUE(NODE)   \
 675   (((struct lang_identifier *)(NODE))->global_value)
 676 /* This represents the value which the identifier has in the current
 677    scope.  */
 678 #define IDENTIFIER_LOCAL_VALUE(NODE)    \
 679   (((struct lang_identifier *)(NODE))->local_value)
 680 /* This represents the value which the identifier has as a label in
 681    the current label scope.  */
 682 #define IDENTIFIER_LABEL_VALUE(NODE)    \
 683   (((struct lang_identifier *)(NODE))->label_value)
 684 /* This is nonzero if the identifier was "made up" by g77 code.  */
 685 #define IDENTIFIER_INVENTED(NODE)       \
 686   (((struct lang_identifier *)(NODE))->invented)
 687
 688 /* In identifiers, C uses the following fields in a special way:
 689    TREE_PUBLIC        to record that there was a previous local extern decl.
 690    TREE_USED          to record that such a decl was used.
 691    TREE_ADDRESSABLE   to record that the address of such a decl was used.  */
 692
 693 /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
 694    that have names.  Here so we can clear out their names' definitions
 695    at the end of the function.  */
 696
 697 static tree named_labels;
 698
 699 /* A list of LABEL_DECLs from outer contexts that are currently shadowed.  */
 700
 701 static tree shadowed_labels;
 702
 703 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 704 \f
 705 /* Return the subscript expression, modified to do range-checking.
 706
 707    `array' is the array to be checked against.
 708    `element' is the subscript expression to check.
 709    `dim' is the dimension number (starting at 0).
 710    `total_dims' is the total number of dimensions (0 for CHARACTER substring).
 711 */
 712
 713 static tree
 714 ffecom_subscript_check_ (tree array, tree element, int dim, int total_dims,
 715                          char *array_name)
 716 {
 717   tree low = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 718   tree high = TYPE_MAX_VALUE (TYPE_DOMAIN (array));
 719   tree cond;
 720   tree die;
 721   tree args;
 722
 723   if (element == error_mark_node)
 724     return element;
 725
 726   if (TREE_TYPE (low) != TREE_TYPE (element))
 727     {
 728       if (TYPE_PRECISION (TREE_TYPE (low))
 729           > TYPE_PRECISION (TREE_TYPE (element)))
 730         element = convert (TREE_TYPE (low), element);
 731       else
 732         {
 733           low = convert (TREE_TYPE (element), low);
 734           if (high)
 735             high = convert (TREE_TYPE (element), high);
 736         }
 737     }
 738
 739   element = ffecom_save_tree (element);
 740   cond = ffecom_2 (LE_EXPR, integer_type_node,
 741                    low,
 742                    element);
 743   if (high)
 744     {
 745       cond = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
 746                        cond,
 747                        ffecom_2 (LE_EXPR, integer_type_node,
 748                                  element,
 749                                  high));
 750     }
 751
 752   {
 753     int len;
 754     char *proc;
 755     char *var;
 756     tree arg3;
 757     tree arg2;
 758     tree arg1;
 759     tree arg4;
 760
 761     switch (total_dims)
 762       {
 763       case 0:
 764         var = xmalloc (strlen (array_name) + 20);
 765         sprintf (&var[0], "%s[%s-substring]",
 766                  array_name,
 767                  dim ? "end" : "start");
 768         len = strlen (var) + 1;
 769         break;
 770
 771       case 1:
 772         len = strlen (array_name) + 1;
 773         var = array_name;
 774         break;
 775
 776       default:
 777         var = xmalloc (strlen (array_name) + 40);
 778         sprintf (&var[0], "%s[subscript-%d-of-%d]",
 779                  array_name,
 780                  dim + 1, total_dims);
 781         len = strlen (var) + 1;
 782         break;
 783       }
 784
 785     arg1 = build_string (len, var);
 786
 787     if (total_dims != 1)
 788       free (var);
 789
 790     TREE_TYPE (arg1)
 791       = build_type_variant (build_array_type (char_type_node,
 792                                               build_range_type
 793                                               (integer_type_node,
 794                                                integer_one_node,
 795                                                build_int_2 (len, 0))),
 796                             1, 0);
 797     TREE_CONSTANT (arg1) = 1;
 798     TREE_STATIC (arg1) = 1;
 799     arg1 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg1)),
 800                      arg1);
 801
 802     /* s_rnge adds one to the element to print it, so bias against
 803        that -- want to print a faithful *subscript* value.  */
 804     arg2 = convert (ffecom_f2c_ftnint_type_node,
 805                     ffecom_2 (MINUS_EXPR,
 806                               TREE_TYPE (element),
 807                               element,
 808                               convert (TREE_TYPE (element),
 809                                        integer_one_node)));
 810
 811     proc = xmalloc ((len = strlen (input_filename)
 812                      + IDENTIFIER_LENGTH (DECL_NAME (current_function_decl))
 813                      + 2));
 814
 815     sprintf (&proc[0], "%s/%s",
 816              input_filename,
 817              IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
 818     arg3 = build_string (len, proc);
 819
 820     free (proc);
 821
 822     TREE_TYPE (arg3)
 823       = build_type_variant (build_array_type (char_type_node,
 824                                               build_range_type
 825                                               (integer_type_node,
 826                                                integer_one_node,
 827                                                build_int_2 (len, 0))),
 828                             1, 0);
 829     TREE_CONSTANT (arg3) = 1;
 830     TREE_STATIC (arg3) = 1;
 831     arg3 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg3)),
 832                      arg3);
 833
 834     arg4 = convert (ffecom_f2c_ftnint_type_node,
 835                     build_int_2 (lineno, 0));
 836
 837     arg1 = build_tree_list (NULL_TREE, arg1);
 838     arg2 = build_tree_list (NULL_TREE, arg2);
 839     arg3 = build_tree_list (NULL_TREE, arg3);
 840     arg4 = build_tree_list (NULL_TREE, arg4);
 841     TREE_CHAIN (arg3) = arg4;
 842     TREE_CHAIN (arg2) = arg3;
 843     TREE_CHAIN (arg1) = arg2;
 844
 845     args = arg1;
 846   }
 847   die = ffecom_call_gfrt (FFECOM_gfrtRANGE,
 848                           args, NULL_TREE);
 849   TREE_SIDE_EFFECTS (die) = 1;
 850
 851   element = ffecom_3 (COND_EXPR,
 852                       TREE_TYPE (element),
 853                       cond,
 854                       element,
 855                       die);
 856
 857   return element;
 858 }
 859
 860 /* Return the computed element of an array reference.
 861
 862    `item' is NULL_TREE, or the transformed pointer to the array.
 863    `expr' is the original opARRAYREF expression, which is transformed
 864      if `item' is NULL_TREE.
 865    `want_ptr' is non-zero if a pointer to the element, instead of
 866      the element itself, is to be returned.  */
 867
 868 static tree
 869 ffecom_arrayref_ (tree item, ffebld expr, int want_ptr)
 870 {
 871   ffebld dims[FFECOM_dimensionsMAX];
 872   int i;
 873   int total_dims;
 874   int flatten = ffe_is_flatten_arrays ();
 875   int need_ptr;
 876   tree array;
 877   tree element;
 878   tree tree_type;
 879   tree tree_type_x;
 880   char *array_name;
 881   ffetype type;
 882   ffebld list;
 883
 884   if (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER)
 885     array_name = ffesymbol_text (ffebld_symter (ffebld_left (expr)));
 886   else
 887     array_name = "[expr?]";
 888
 889   /* Build up ARRAY_REFs in reverse order (since we're column major
 890      here in Fortran land). */
 891
 892   for (i = 0, list = ffebld_right (expr);
 893        list != NULL;
 894        ++i, list = ffebld_trail (list))
 895     {
 896       dims[i] = ffebld_head (list);
 897       type = ffeinfo_type (ffebld_basictype (dims[i]),
 898                            ffebld_kindtype (dims[i]));
 899       if (! flatten
 900           && ffecom_typesize_pointer_ > ffecom_typesize_integer1_
 901           && ffetype_size (type) > ffecom_typesize_integer1_)
 902         /* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit
 903            pointers and 32-bit integers.  Do the full 64-bit pointer
 904            arithmetic, for codes using arrays for nonstandard heap-like
 905            work.  */
 906         flatten = 1;
 907     }
 908
 909   total_dims = i;
 910
 911   need_ptr = want_ptr || flatten;
 912
 913   if (! item)
 914     {
 915       if (need_ptr)
 916         item = ffecom_ptr_to_expr (ffebld_left (expr));
 917       else
 918         item = ffecom_expr (ffebld_left (expr));
 919
 920       if (item == error_mark_node)
 921         return item;
 922
 923       if (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING
 924           && ! mark_addressable (item))
 925         return error_mark_node;
 926     }
 927
 928   if (item == error_mark_node)
 929     return item;
 930
 931   if (need_ptr)
 932     {
 933       tree min;
 934
 935       for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
 936            i >= 0;
 937            --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
 938         {
 939           min = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 940           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 941           if (flag_bounds_check)
 942             element = ffecom_subscript_check_ (array, element, i, total_dims,
 943                                                array_name);
 944           if (element == error_mark_node)
 945             return element;
 946
 947           /* Widen integral arithmetic as desired while preserving
 948              signedness.  */
 949           tree_type = TREE_TYPE (element);
 950           tree_type_x = tree_type;
 951           if (tree_type
 952               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
 953               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
 954             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
 955
 956           if (TREE_TYPE (min) != tree_type_x)
 957             min = convert (tree_type_x, min);
 958           if (TREE_TYPE (element) != tree_type_x)
 959             element = convert (tree_type_x, element);
 960
 961           item = ffecom_2 (PLUS_EXPR,
 962                            build_pointer_type (TREE_TYPE (array)),
 963                            item,
 964                            size_binop (MULT_EXPR,
 965                                        size_in_bytes (TREE_TYPE (array)),
 966                                        convert (sizetype,
 967                                                 fold (build (MINUS_EXPR,
 968                                                              tree_type_x,
 969                                                              element, min)))));
 970         }
 971       if (! want_ptr)
 972         {
 973           item = ffecom_1 (INDIRECT_REF,
 974                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
 975                            item);
 976         }
 977     }
 978   else
 979     {
 980       for (--i;
 981            i >= 0;
 982            --i)
 983         {
 984           array = TYPE_MAIN_VARIANT (TREE_TYPE (item));
 985
 986           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 987           if (flag_bounds_check)
 988             element = ffecom_subscript_check_ (array, element, i, total_dims,
 989                                                array_name);
 990           if (element == error_mark_node)
 991             return element;
 992
 993           /* Widen integral arithmetic as desired while preserving
 994              signedness.  */
 995           tree_type = TREE_TYPE (element);
 996           tree_type_x = tree_type;
 997           if (tree_type
 998               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
 999               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
1000             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
1001
1002           element = convert (tree_type_x, element);
1003
1004           item = ffecom_2 (ARRAY_REF,
1005                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
1006                            item,
1007                            element);
1008         }
1009     }
1010
1011   return item;
1012 }
1013
1014 /* This is like gcc's stabilize_reference -- in fact, most of the code
1015    comes from that -- but it handles the situation where the reference
1016    is going to have its subparts picked at, and it shouldn't change
1017    (or trigger extra invocations of functions in the subtrees) due to
1018    this.  save_expr is a bit overzealous, because we don't need the
1019    entire thing calculated and saved like a temp.  So, for DECLs, no
1020    change is needed, because these are stable aggregates, and ARRAY_REF
1021    and such might well be stable too, but for things like calculations,
1022    we do need to calculate a snapshot of a value before picking at it.  */
1023
1024 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1025 static tree
1026 ffecom_stabilize_aggregate_ (tree ref)
1027 {
1028   tree result;
1029   enum tree_code code = TREE_CODE (ref);
1030
1031   switch (code)
1032     {
1033     case VAR_DECL:
1034     case PARM_DECL:
1035     case RESULT_DECL:
1036       /* No action is needed in this case.  */
1037       return ref;
1038
1039     case NOP_EXPR:
1040     case CONVERT_EXPR:
1041     case FLOAT_EXPR:
1042     case FIX_TRUNC_EXPR:
1043     case FIX_FLOOR_EXPR:
1044     case FIX_ROUND_EXPR:
1045     case FIX_CEIL_EXPR:
1046       result = build_nt (code, stabilize_reference (TREE_OPERAND (ref, 0)));
1047       break;
1048
1049     case INDIRECT_REF:
1050       result = build_nt (INDIRECT_REF,
1051                          stabilize_reference_1 (TREE_OPERAND (ref, 0)));
1052       break;
1053
1054     case COMPONENT_REF:
1055       result = build_nt (COMPONENT_REF,
1056                          stabilize_reference (TREE_OPERAND (ref, 0)),
1057                          TREE_OPERAND (ref, 1));
1058       break;
1059
1060     case BIT_FIELD_REF:
1061       result = build_nt (BIT_FIELD_REF,
1062                          stabilize_reference (TREE_OPERAND (ref, 0)),
1063                          stabilize_reference_1 (TREE_OPERAND (ref, 1)),
1064                          stabilize_reference_1 (TREE_OPERAND (ref, 2)));
1065       break;
1066
1067     case ARRAY_REF:
1068       result = build_nt (ARRAY_REF,
1069                          stabilize_reference (TREE_OPERAND (ref, 0)),
1070                          stabilize_reference_1 (TREE_OPERAND (ref, 1)));
1071       break;
1072
1073     case COMPOUND_EXPR:
1074       result = build_nt (COMPOUND_EXPR,
1075                          stabilize_reference_1 (TREE_OPERAND (ref, 0)),
1076                          stabilize_reference (TREE_OPERAND (ref, 1)));
1077       break;
1078
1079     case RTL_EXPR:
1080       result = build1 (INDIRECT_REF, TREE_TYPE (ref),
1081                        save_expr (build1 (ADDR_EXPR,
1082                                           build_pointer_type (TREE_TYPE (ref)),
1083                                           ref)));
1084       break;
1085
1086
1087     default:
1088       return save_expr (ref);
1089
1090     case ERROR_MARK:
1091       return error_mark_node;
1092     }
1093
1094   TREE_TYPE (result) = TREE_TYPE (ref);
1095   TREE_READONLY (result) = TREE_READONLY (ref);
1096   TREE_SIDE_EFFECTS (result) = TREE_SIDE_EFFECTS (ref);
1097   TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
1098
1099   return result;
1100 }
1101 #endif
1102
1103 /* A rip-off of gcc's convert.c convert_to_complex function,
1104    reworked to handle complex implemented as C structures
1105    (RECORD_TYPE with two fields, real and imaginary `r' and `i').  */
1106
1107 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1108 static tree
1109 ffecom_convert_to_complex_ (tree type, tree expr)
1110 {
1111   register enum tree_code form = TREE_CODE (TREE_TYPE (expr));
1112   tree subtype;
1113
1114   assert (TREE_CODE (type) == RECORD_TYPE);
1115
1116   subtype = TREE_TYPE (TYPE_FIELDS (type));
1117
1118   if (form == REAL_TYPE || form == INTEGER_TYPE || form == ENUMERAL_TYPE)
1119     {
1120       expr = convert (subtype, expr);
1121       return ffecom_2 (COMPLEX_EXPR, type, expr,
1122                        convert (subtype, integer_zero_node));
1123     }
1124
1125   if (form == RECORD_TYPE)
1126     {
1127       tree elt_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr)));
1128       if (TYPE_MAIN_VARIANT (elt_type) == TYPE_MAIN_VARIANT (subtype))
1129         return expr;
1130       else
1131         {
1132           expr = save_expr (expr);
1133           return ffecom_2 (COMPLEX_EXPR,
1134                            type,
1135                            convert (subtype,
1136                                     ffecom_1 (REALPART_EXPR,
1137                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1138                                               expr)),
1139                            convert (subtype,
1140                                     ffecom_1 (IMAGPART_EXPR,
1141                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1142                                               expr)));
1143         }
1144     }
1145
1146   if (form == POINTER_TYPE || form == REFERENCE_TYPE)
1147     error ("pointer value used where a complex was expected");
1148   else
1149     error ("aggregate value used where a complex was expected");
1150
1151   return ffecom_2 (COMPLEX_EXPR, type,
1152                    convert (subtype, integer_zero_node),
1153                    convert (subtype, integer_zero_node));
1154 }
1155 #endif
1156
1157 /* Like gcc's convert(), but crashes if widening might happen.  */
1158
1159 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1160 static tree
1161 ffecom_convert_narrow_ (type, expr)
1162      tree type, expr;
1163 {
1164   register tree e = expr;
1165   register enum tree_code code = TREE_CODE (type);
1166
1167   if (type == TREE_TYPE (e)
1168       || TREE_CODE (e) == ERROR_MARK)
1169     return e;
1170   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1171     return fold (build1 (NOP_EXPR, type, e));
1172   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1173       || code == ERROR_MARK)
1174     return error_mark_node;
1175   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1176     {
1177       assert ("void value not ignored as it ought to be" == NULL);
1178       return error_mark_node;
1179     }
1180   assert (code != VOID_TYPE);
1181   if ((code != RECORD_TYPE)
1182       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1183     assert ("converting COMPLEX to REAL" == NULL);
1184   assert (code != ENUMERAL_TYPE);
1185   if (code == INTEGER_TYPE)
1186     {
1187       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1188                && TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)))
1189               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1190                   && (TYPE_PRECISION (type)
1191                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1192       return fold (convert_to_integer (type, e));
1193     }
1194   if (code == POINTER_TYPE)
1195     {
1196       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1197       return fold (convert_to_pointer (type, e));
1198     }
1199   if (code == REAL_TYPE)
1200     {
1201       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1202       assert (TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)));
1203       return fold (convert_to_real (type, e));
1204     }
1205   if (code == COMPLEX_TYPE)
1206     {
1207       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1208       assert (TYPE_PRECISION (TREE_TYPE (type)) <= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1209       return fold (convert_to_complex (type, e));
1210     }
1211   if (code == RECORD_TYPE)
1212     {
1213       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1214       /* Check that at least the first field name agrees.  */
1215       assert (DECL_NAME (TYPE_FIELDS (type))
1216               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1217       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1218               <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1219       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1220           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1221         return e;
1222       return fold (ffecom_convert_to_complex_ (type, e));
1223     }
1224
1225   assert ("conversion to non-scalar type requested" == NULL);
1226   return error_mark_node;
1227 }
1228 #endif
1229
1230 /* Like gcc's convert(), but crashes if narrowing might happen.  */
1231
1232 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1233 static tree
1234 ffecom_convert_widen_ (type, expr)
1235      tree type, expr;
1236 {
1237   register tree e = expr;
1238   register enum tree_code code = TREE_CODE (type);
1239
1240   if (type == TREE_TYPE (e)
1241       || TREE_CODE (e) == ERROR_MARK)
1242     return e;
1243   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1244     return fold (build1 (NOP_EXPR, type, e));
1245   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1246       || code == ERROR_MARK)
1247     return error_mark_node;
1248   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1249     {
1250       assert ("void value not ignored as it ought to be" == NULL);
1251       return error_mark_node;
1252     }
1253   assert (code != VOID_TYPE);
1254   if ((code != RECORD_TYPE)
1255       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1256     assert ("narrowing COMPLEX to REAL" == NULL);
1257   assert (code != ENUMERAL_TYPE);
1258   if (code == INTEGER_TYPE)
1259     {
1260       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1261                && TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)))
1262               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1263                   && (TYPE_PRECISION (type)
1264                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1265       return fold (convert_to_integer (type, e));
1266     }
1267   if (code == POINTER_TYPE)
1268     {
1269       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1270       return fold (convert_to_pointer (type, e));
1271     }
1272   if (code == REAL_TYPE)
1273     {
1274       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1275       assert (TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)));
1276       return fold (convert_to_real (type, e));
1277     }
1278   if (code == COMPLEX_TYPE)
1279     {
1280       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1281       assert (TYPE_PRECISION (TREE_TYPE (type)) >= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1282       return fold (convert_to_complex (type, e));
1283     }
1284   if (code == RECORD_TYPE)
1285     {
1286       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1287       /* Check that at least the first field name agrees.  */
1288       assert (DECL_NAME (TYPE_FIELDS (type))
1289               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1290       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1291               >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1292       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1293           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1294         return e;
1295       return fold (ffecom_convert_to_complex_ (type, e));
1296     }
1297
1298   assert ("conversion to non-scalar type requested" == NULL);
1299   return error_mark_node;
1300 }
1301 #endif
1302
1303 /* Handles making a COMPLEX type, either the standard
1304    (but buggy?) gbe way, or the safer (but less elegant?)
1305    f2c way.  */
1306
1307 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1308 static tree
1309 ffecom_make_complex_type_ (tree subtype)
1310 {
1311   tree type;
1312   tree realfield;
1313   tree imagfield;
1314
1315   if (ffe_is_emulate_complex ())
1316     {
1317       type = make_node (RECORD_TYPE);
1318       realfield = ffecom_decl_field (type, NULL_TREE, "r", subtype);
1319       imagfield = ffecom_decl_field (type, realfield, "i", subtype);
1320       TYPE_FIELDS (type) = realfield;
1321       layout_type (type);
1322     }
1323   else
1324     {
1325       type = make_node (COMPLEX_TYPE);
1326       TREE_TYPE (type) = subtype;
1327       layout_type (type);
1328     }
1329
1330   return type;
1331 }
1332 #endif
1333
1334 /* Chooses either the gbe or the f2c way to build a
1335    complex constant.  */
1336
1337 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1338 static tree
1339 ffecom_build_complex_constant_ (tree type, tree realpart, tree imagpart)
1340 {
1341   tree bothparts;
1342
1343   if (ffe_is_emulate_complex ())
1344     {
1345       bothparts = build_tree_list (TYPE_FIELDS (type), realpart);
1346       TREE_CHAIN (bothparts) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), imagpart);
1347       bothparts = build (CONSTRUCTOR, type, NULL_TREE, bothparts);
1348     }
1349   else
1350     {
1351       bothparts = build_complex (type, realpart, imagpart);
1352     }
1353
1354   return bothparts;
1355 }
1356 #endif
1357
1358 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1359 static tree
1360 ffecom_arglist_expr_ (const char *c, ffebld expr)
1361 {
1362   tree list;
1363   tree *plist = &list;
1364   tree trail = NULL_TREE;       /* Append char length args here. */
1365   tree *ptrail = &trail;
1366   tree length;
1367   ffebld exprh;
1368   tree item;
1369   bool ptr = FALSE;
1370   tree wanted = NULL_TREE;
1371   static char zed[] = "0";
1372
1373   if (c == NULL)
1374     c = &zed[0];
1375
1376   while (expr != NULL)
1377     {
1378       if (*c != '\0')
1379         {
1380           ptr = FALSE;
1381           if (*c == '&')
1382             {
1383               ptr = TRUE;
1384               ++c;
1385             }
1386           switch (*(c++))
1387             {
1388             case '\0':
1389               ptr = TRUE;
1390               wanted = NULL_TREE;
1391               break;
1392
1393             case 'a':
1394               assert (ptr);
1395               wanted = NULL_TREE;
1396               break;
1397
1398             case 'c':
1399               wanted = ffecom_f2c_complex_type_node;
1400               break;
1401
1402             case 'd':
1403               wanted = ffecom_f2c_doublereal_type_node;
1404               break;
1405
1406             case 'e':
1407               wanted = ffecom_f2c_doublecomplex_type_node;
1408               break;
1409
1410             case 'f':
1411               wanted = ffecom_f2c_real_type_node;
1412               break;
1413
1414             case 'i':
1415               wanted = ffecom_f2c_integer_type_node;
1416               break;
1417
1418             case 'j':
1419               wanted = ffecom_f2c_longint_type_node;
1420               break;
1421
1422             default:
1423               assert ("bad argstring code" == NULL);
1424               wanted = NULL_TREE;
1425               break;
1426             }
1427         }
1428
1429       exprh = ffebld_head (expr);
1430       if (exprh == NULL)
1431         wanted = NULL_TREE;
1432
1433       if ((wanted == NULL_TREE)
1434           || (ptr
1435               && (TYPE_MODE
1436                   (ffecom_tree_type[ffeinfo_basictype (ffebld_info (exprh))]
1437                    [ffeinfo_kindtype (ffebld_info (exprh))])
1438                    == TYPE_MODE (wanted))))
1439         *plist
1440           = build_tree_list (NULL_TREE,
1441                              ffecom_arg_ptr_to_expr (exprh,
1442                                                      &length));
1443       else
1444         {
1445           item = ffecom_arg_expr (exprh, &length);
1446           item = ffecom_convert_widen_ (wanted, item);
1447           if (ptr)
1448             {
1449               item = ffecom_1 (ADDR_EXPR,
1450                                build_pointer_type (TREE_TYPE (item)),
1451                                item);
1452             }
1453           *plist
1454             = build_tree_list (NULL_TREE,
1455                                item);
1456         }
1457
1458       plist = &TREE_CHAIN (*plist);
1459       expr = ffebld_trail (expr);
1460       if (length != NULL_TREE)
1461         {
1462           *ptrail = build_tree_list (NULL_TREE, length);
1463           ptrail = &TREE_CHAIN (*ptrail);
1464         }
1465     }
1466
1467   /* We've run out of args in the call; if the implementation expects
1468      more, supply null pointers for them, which the implementation can
1469      check to see if an arg was omitted. */
1470
1471   while (*c != '\0' && *c != '0')
1472     {
1473       if (*c == '&')
1474         ++c;
1475       else
1476         assert ("missing arg to run-time routine!" == NULL);
1477
1478       switch (*(c++))
1479         {
1480         case '\0':
1481         case 'a':
1482         case 'c':
1483         case 'd':
1484         case 'e':
1485         case 'f':
1486         case 'i':
1487         case 'j':
1488           break;
1489
1490         default:
1491           assert ("bad arg string code" == NULL);
1492           break;
1493         }
1494       *plist
1495         = build_tree_list (NULL_TREE,
1496                            null_pointer_node);
1497       plist = &TREE_CHAIN (*plist);
1498     }
1499
1500   *plist = trail;
1501
1502   return list;
1503 }
1504 #endif
1505
1506 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1507 static tree
1508 ffecom_widest_expr_type_ (ffebld list)
1509 {
1510   ffebld item;
1511   ffebld widest = NULL;
1512   ffetype type;
1513   ffetype widest_type = NULL;
1514   tree t;
1515
1516   for (; list != NULL; list = ffebld_trail (list))
1517     {
1518       item = ffebld_head (list);
1519       if (item == NULL)
1520         continue;
1521       if ((widest != NULL)
1522           && (ffeinfo_basictype (ffebld_info (item))
1523               != ffeinfo_basictype (ffebld_info (widest))))
1524         continue;
1525       type = ffeinfo_type (ffeinfo_basictype (ffebld_info (item)),
1526                            ffeinfo_kindtype (ffebld_info (item)));
1527       if ((widest == FFEINFO_kindtypeNONE)
1528           || (ffetype_size (type)
1529               > ffetype_size (widest_type)))
1530         {
1531           widest = item;
1532           widest_type = type;
1533         }
1534     }
1535
1536   assert (widest != NULL);
1537   t = ffecom_tree_type[ffeinfo_basictype (ffebld_info (widest))]
1538     [ffeinfo_kindtype (ffebld_info (widest))];
1539   assert (t != NULL_TREE);
1540   return t;
1541 }
1542 #endif
1543
1544 /* Check whether a partial overlap between two expressions is possible.
1545
1546    Can *starting* to write a portion of expr1 change the value
1547    computed (perhaps already, *partially*) by expr2?
1548
1549    Currently, this is a concern only for a COMPLEX expr1.  But if it
1550    isn't in COMMON or local EQUIVALENCE, since we don't support
1551    aliasing of arguments, it isn't a concern.  */
1552
1553 static bool
1554 ffecom_possible_partial_overlap_ (ffebld expr1, ffebld expr2 ATTRIBUTE_UNUSED)
1555 {
1556   ffesymbol sym;
1557   ffestorag st;
1558
1559   switch (ffebld_op (expr1))
1560     {
1561     case FFEBLD_opSYMTER:
1562       sym = ffebld_symter (expr1);
1563       break;
1564
1565     case FFEBLD_opARRAYREF:
1566       if (ffebld_op (ffebld_left (expr1)) != FFEBLD_opSYMTER)
1567         return FALSE;
1568       sym = ffebld_symter (ffebld_left (expr1));
1569       break;
1570
1571     default:
1572       return FALSE;
1573     }
1574
1575   if (ffesymbol_where (sym) != FFEINFO_whereCOMMON
1576       && (ffesymbol_where (sym) != FFEINFO_whereLOCAL
1577           || ! (st = ffesymbol_storage (sym))
1578           || ! ffestorag_parent (st)))
1579     return FALSE;
1580
1581   /* It's in COMMON or local EQUIVALENCE.  */
1582
1583   return TRUE;
1584 }
1585
1586 /* Check whether dest and source might overlap.  ffebld versions of these
1587    might or might not be passed, will be NULL if not.
1588
1589    The test is really whether source_tree is modifiable and, if modified,
1590    might overlap destination such that the value(s) in the destination might
1591    change before it is finally modified.  dest_* are the canonized
1592    destination itself.  */
1593
1594 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1595 static bool
1596 ffecom_overlap_ (tree dest_decl, tree dest_offset, tree dest_size,
1597                  tree source_tree, ffebld source UNUSED,
1598                  bool scalar_arg)
1599 {
1600   tree source_decl;
1601   tree source_offset;
1602   tree source_size;
1603   tree t;
1604
1605   if (source_tree == NULL_TREE)
1606     return FALSE;
1607
1608   switch (TREE_CODE (source_tree))
1609     {
1610     case ERROR_MARK:
1611     case IDENTIFIER_NODE:
1612     case INTEGER_CST:
1613     case REAL_CST:
1614     case COMPLEX_CST:
1615     case STRING_CST:
1616     case CONST_DECL:
1617     case VAR_DECL:
1618     case RESULT_DECL:
1619     case FIELD_DECL:
1620     case MINUS_EXPR:
1621     case MULT_EXPR:
1622     case TRUNC_DIV_EXPR:
1623     case CEIL_DIV_EXPR:
1624     case FLOOR_DIV_EXPR:
1625     case ROUND_DIV_EXPR:
1626     case TRUNC_MOD_EXPR:
1627     case CEIL_MOD_EXPR:
1628     case FLOOR_MOD_EXPR:
1629     case ROUND_MOD_EXPR:
1630     case RDIV_EXPR:
1631     case EXACT_DIV_EXPR:
1632     case FIX_TRUNC_EXPR:
1633     case FIX_CEIL_EXPR:
1634     case FIX_FLOOR_EXPR:
1635     case FIX_ROUND_EXPR:
1636     case FLOAT_EXPR:
1637     case EXPON_EXPR:
1638     case NEGATE_EXPR:
1639     case MIN_EXPR:
1640     case MAX_EXPR:
1641     case ABS_EXPR:
1642     case FFS_EXPR:
1643     case LSHIFT_EXPR:
1644     case RSHIFT_EXPR:
1645     case LROTATE_EXPR:
1646     case RROTATE_EXPR:
1647     case BIT_IOR_EXPR:
1648     case BIT_XOR_EXPR:
1649     case BIT_AND_EXPR:
1650     case BIT_ANDTC_EXPR:
1651     case BIT_NOT_EXPR:
1652     case TRUTH_ANDIF_EXPR:
1653     case TRUTH_ORIF_EXPR:
1654     case TRUTH_AND_EXPR:
1655     case TRUTH_OR_EXPR:
1656     case TRUTH_XOR_EXPR:
1657     case TRUTH_NOT_EXPR:
1658     case LT_EXPR:
1659     case LE_EXPR:
1660     case GT_EXPR:
1661     case GE_EXPR:
1662     case EQ_EXPR:
1663     case NE_EXPR:
1664     case COMPLEX_EXPR:
1665     case CONJ_EXPR:
1666     case REALPART_EXPR:
1667     case IMAGPART_EXPR:
1668     case LABEL_EXPR:
1669     case COMPONENT_REF:
1670       return FALSE;
1671
1672     case COMPOUND_EXPR:
1673       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1674                               TREE_OPERAND (source_tree, 1), NULL,
1675                               scalar_arg);
1676
1677     case MODIFY_EXPR:
1678       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1679                               TREE_OPERAND (source_tree, 0), NULL,
1680                               scalar_arg);
1681
1682     case CONVERT_EXPR:
1683     case NOP_EXPR:
1684     case NON_LVALUE_EXPR:
1685     case PLUS_EXPR:
1686       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1687         return TRUE;
1688
1689       ffecom_tree_canonize_ptr_ (&source_decl, &source_offset,
1690                                  source_tree);
1691       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1692       break;
1693
1694     case COND_EXPR:
1695       return
1696         ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1697                          TREE_OPERAND (source_tree, 1), NULL,
1698                          scalar_arg)
1699           || ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1700                               TREE_OPERAND (source_tree, 2), NULL,
1701                               scalar_arg);
1702
1703
1704     case ADDR_EXPR:
1705       ffecom_tree_canonize_ref_ (&source_decl, &source_offset,
1706                                  &source_size,
1707                                  TREE_OPERAND (source_tree, 0));
1708       break;
1709
1710     case PARM_DECL:
1711       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1712         return TRUE;
1713
1714       source_decl = source_tree;
1715       source_offset = size_zero_node;
1716       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1717       break;
1718
1719     case SAVE_EXPR:
1720     case REFERENCE_EXPR:
1721     case PREDECREMENT_EXPR:
1722     case PREINCREMENT_EXPR:
1723     case POSTDECREMENT_EXPR:
1724     case POSTINCREMENT_EXPR:
1725     case INDIRECT_REF:
1726     case ARRAY_REF:
1727     case CALL_EXPR:
1728     default:
1729       return TRUE;
1730     }
1731
1732   /* Come here when source_decl, source_offset, and source_size filled
1733      in appropriately.  */
1734
1735   if (source_decl == NULL_TREE)
1736     return FALSE;               /* No decl involved, so no overlap. */
1737
1738   if (source_decl != dest_decl)
1739     return FALSE;               /* Different decl, no overlap. */
1740
1741   if (TREE_CODE (dest_size) == ERROR_MARK)
1742     return TRUE;                /* Assignment into entire assumed-size
1743                                    array?  Shouldn't happen.... */
1744
1745   t = ffecom_2 (LE_EXPR, integer_type_node,
1746                 ffecom_2 (PLUS_EXPR, TREE_TYPE (dest_offset),
1747                           dest_offset,
1748                           convert (TREE_TYPE (dest_offset),
1749                                    dest_size)),
1750                 convert (TREE_TYPE (dest_offset),
1751                          source_offset));
1752
1753   if (integer_onep (t))
1754     return FALSE;               /* Destination precedes source. */
1755
1756   if (!scalar_arg
1757       || (source_size == NULL_TREE)
1758       || (TREE_CODE (source_size) == ERROR_MARK)
1759       || integer_zerop (source_size))
1760     return TRUE;                /* No way to tell if dest follows source. */
1761
1762   t = ffecom_2 (LE_EXPR, integer_type_node,
1763                 ffecom_2 (PLUS_EXPR, TREE_TYPE (source_offset),
1764                           source_offset,
1765                           convert (TREE_TYPE (source_offset),
1766                                    source_size)),
1767                 convert (TREE_TYPE (source_offset),
1768                          dest_offset));
1769
1770   if (integer_onep (t))
1771     return FALSE;               /* Destination follows source. */
1772
1773   return TRUE;          /* Destination and source overlap. */
1774 }
1775 #endif
1776
1777 /* Check whether dest might overlap any of a list of arguments or is
1778    in a COMMON area the callee might know about (and thus modify).  */
1779
1780 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1781 static bool
1782 ffecom_args_overlapping_ (tree dest_tree, ffebld dest UNUSED,
1783                           tree args, tree callee_commons,
1784                           bool scalar_args)
1785 {
1786   tree arg;
1787   tree dest_decl;
1788   tree dest_offset;
1789   tree dest_size;
1790
1791   ffecom_tree_canonize_ref_ (&dest_decl, &dest_offset, &dest_size,
1792                              dest_tree);
1793
1794   if (dest_decl == NULL_TREE)
1795     return FALSE;               /* Seems unlikely! */
1796
1797   /* If the decl cannot be determined reliably, or if its in COMMON
1798      and the callee isn't known to not futz with COMMON via other
1799      means, overlap might happen.  */
1800
1801   if ((TREE_CODE (dest_decl) == ERROR_MARK)
1802       || ((callee_commons != NULL_TREE)
1803           && TREE_PUBLIC (dest_decl)))
1804     return TRUE;
1805
1806   for (; args != NULL_TREE; args = TREE_CHAIN (args))
1807     {
1808       if (((arg = TREE_VALUE (args)) != NULL_TREE)
1809           && ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1810                               arg, NULL, scalar_args))
1811         return TRUE;
1812     }
1813
1814   return FALSE;
1815 }
1816 #endif
1817
1818 /* Build a string for a variable name as used by NAMELIST.  This means that
1819    if we're using the f2c library, we build an uppercase string, since
1820    f2c does this.  */
1821
1822 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1823 static tree
1824 ffecom_build_f2c_string_ (int i, const char *s)
1825 {
1826   if (!ffe_is_f2c_library ())
1827     return build_string (i, s);
1828
1829   {
1830     char *tmp;
1831     const char *p;
1832     char *q;
1833     char space[34];
1834     tree t;
1835
1836     if (((size_t) i) > ARRAY_SIZE (space))
1837       tmp = malloc_new_ks (malloc_pool_image (), "f2c_string", i);
1838     else
1839       tmp = &space[0];
1840
1841     for (p = s, q = tmp; *p != '\0'; ++p, ++q)
1842       *q = ffesrc_toupper (*p);
1843     *q = '\0';
1844
1845     t = build_string (i, tmp);
1846
1847     if (((size_t) i) > ARRAY_SIZE (space))
1848       malloc_kill_ks (malloc_pool_image (), tmp, i);
1849
1850     return t;
1851   }
1852 }
1853
1854 #endif
1855 /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
1856    type to just get whatever the function returns), handling the
1857    f2c value-returning convention, if required, by prepending
1858    to the arglist a pointer to a temporary to receive the return value.  */
1859
1860 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1861 static tree
1862 ffecom_call_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1863               tree type, tree args, tree dest_tree,
1864               ffebld dest, bool *dest_used, tree callee_commons,
1865               bool scalar_args, tree hook)
1866 {
1867   tree item;
1868   tree tempvar;
1869
1870   if (dest_used != NULL)
1871     *dest_used = FALSE;
1872
1873   if (is_f2c_complex)
1874     {
1875       if ((dest_used == NULL)
1876           || (dest == NULL)
1877           || (ffeinfo_basictype (ffebld_info (dest))
1878               != FFEINFO_basictypeCOMPLEX)
1879           || (ffeinfo_kindtype (ffebld_info (dest)) != kt)
1880           || ((type != NULL_TREE) && (TREE_TYPE (dest_tree) != type))
1881           || ffecom_args_overlapping_ (dest_tree, dest, args,
1882                                        callee_commons,
1883                                        scalar_args))
1884         {
1885 #ifdef HOHO
1886           tempvar = ffecom_make_tempvar (ffecom_tree_type
1887                                          [FFEINFO_basictypeCOMPLEX][kt],
1888                                          FFETARGET_charactersizeNONE,
1889                                          -1);
1890 #else
1891           tempvar = hook;
1892           assert (tempvar);
1893 #endif
1894         }
1895       else
1896         {
1897           *dest_used = TRUE;
1898           tempvar = dest_tree;
1899           type = NULL_TREE;
1900         }
1901
1902       item
1903         = build_tree_list (NULL_TREE,
1904                            ffecom_1 (ADDR_EXPR,
1905                                      build_pointer_type (TREE_TYPE (tempvar)),
1906                                      tempvar));
1907       TREE_CHAIN (item) = args;
1908
1909       item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1910                         item, NULL_TREE);
1911
1912       if (tempvar != dest_tree)
1913         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item, tempvar);
1914     }
1915   else
1916     item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1917                       args, NULL_TREE);
1918
1919   if ((type != NULL_TREE) && (TREE_TYPE (item) != type))
1920     item = ffecom_convert_narrow_ (type, item);
1921
1922   return item;
1923 }
1924 #endif
1925
1926 /* Given two arguments, transform them and make a call to the given
1927    function via ffecom_call_.  */
1928
1929 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1930 static tree
1931 ffecom_call_binop_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1932                     tree type, ffebld left, ffebld right,
1933                     tree dest_tree, ffebld dest, bool *dest_used,
1934                     tree callee_commons, bool scalar_args, tree hook)
1935 {
1936   tree left_tree;
1937   tree right_tree;
1938   tree left_length;
1939   tree right_length;
1940
1941   left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
1942   right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
1943
1944   left_tree = build_tree_list (NULL_TREE, left_tree);
1945   right_tree = build_tree_list (NULL_TREE, right_tree);
1946   TREE_CHAIN (left_tree) = right_tree;
1947
1948   if (left_length != NULL_TREE)
1949     {
1950       left_length = build_tree_list (NULL_TREE, left_length);
1951       TREE_CHAIN (right_tree) = left_length;
1952     }
1953
1954   if (right_length != NULL_TREE)
1955     {
1956       right_length = build_tree_list (NULL_TREE, right_length);
1957       if (left_length != NULL_TREE)
1958         TREE_CHAIN (left_length) = right_length;
1959       else
1960         TREE_CHAIN (right_tree) = right_length;
1961     }
1962
1963   return ffecom_call_ (fn, kt, is_f2c_complex, type, left_tree,
1964                        dest_tree, dest, dest_used, callee_commons,
1965                        scalar_args, hook);
1966 }
1967 #endif
1968
1969 /* Return ptr/length args for char subexpression
1970
1971    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
1972    subexpressions by constructing the appropriate trees for the ptr-to-
1973    character-text and length-of-character-text arguments in a calling
1974    sequence.
1975
1976    Note that if with_null is TRUE, and the expression is an opCONTER,
1977    a null byte is appended to the string.  */
1978
1979 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1980 static void
1981 ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null)
1982 {
1983   tree item;
1984   tree high;
1985   ffetargetCharacter1 val;
1986   ffetargetCharacterSize newlen;
1987
1988   switch (ffebld_op (expr))
1989     {
1990     case FFEBLD_opCONTER:
1991       val = ffebld_constant_character1 (ffebld_conter (expr));
1992       newlen = ffetarget_length_character1 (val);
1993       if (with_null)
1994         {
1995           /* Begin FFETARGET-NULL-KLUDGE.  */
1996           if (newlen != 0)
1997             ++newlen;
1998         }
1999       *length = build_int_2 (newlen, 0);
2000       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2001       high = build_int_2 (newlen, 0);
2002       TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
2003       item = build_string (newlen,
2004                            ffetarget_text_character1 (val));
2005       /* End FFETARGET-NULL-KLUDGE.  */
2006       TREE_TYPE (item)
2007         = build_type_variant
2008           (build_array_type
2009            (char_type_node,
2010             build_range_type
2011             (ffecom_f2c_ftnlen_type_node,
2012              ffecom_f2c_ftnlen_one_node,
2013              high)),
2014            1, 0);
2015       TREE_CONSTANT (item) = 1;
2016       TREE_STATIC (item) = 1;
2017       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
2018                        item);
2019       break;
2020
2021     case FFEBLD_opSYMTER:
2022       {
2023         ffesymbol s = ffebld_symter (expr);
2024
2025         item = ffesymbol_hook (s).decl_tree;
2026         if (item == NULL_TREE)
2027           {
2028             s = ffecom_sym_transform_ (s);
2029             item = ffesymbol_hook (s).decl_tree;
2030           }
2031         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
2032           {
2033             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
2034               *length = ffesymbol_hook (s).length_tree;
2035             else
2036               {
2037                 *length = build_int_2 (ffesymbol_size (s), 0);
2038                 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2039               }
2040           }
2041         else if (item == error_mark_node)
2042           *length = error_mark_node;
2043         else
2044           /* FFEINFO_kindFUNCTION.  */
2045           *length = NULL_TREE;
2046         if (!ffesymbol_hook (s).addr
2047             && (item != error_mark_node))
2048           item = ffecom_1 (ADDR_EXPR,
2049                            build_pointer_type (TREE_TYPE (item)),
2050                            item);
2051       }
2052       break;
2053
2054     case FFEBLD_opARRAYREF:
2055       {
2056         ffecom_char_args_ (&item, length, ffebld_left (expr));
2057
2058         if (item == error_mark_node || *length == error_mark_node)
2059           {
2060             item = *length = error_mark_node;
2061             break;
2062           }
2063
2064         item = ffecom_arrayref_ (item, expr, 1);
2065       }
2066       break;
2067
2068     case FFEBLD_opSUBSTR:
2069       {
2070         ffebld start;
2071         ffebld end;
2072         ffebld thing = ffebld_right (expr);
2073         tree start_tree;
2074         tree end_tree;
2075         char *char_name;
2076         ffebld left_symter;
2077         tree array;
2078
2079         assert (ffebld_op (thing) == FFEBLD_opITEM);
2080         start = ffebld_head (thing);
2081         thing = ffebld_trail (thing);
2082         assert (ffebld_trail (thing) == NULL);
2083         end = ffebld_head (thing);
2084
2085         /* Determine name for pretty-printing range-check errors.  */
2086         for (left_symter = ffebld_left (expr);
2087              left_symter && ffebld_op (left_symter) == FFEBLD_opARRAYREF;
2088              left_symter = ffebld_left (left_symter))
2089           ;
2090         if (ffebld_op (left_symter) == FFEBLD_opSYMTER)
2091           char_name = ffesymbol_text (ffebld_symter (left_symter));
2092         else
2093           char_name = "[expr?]";
2094
2095         ffecom_char_args_ (&item, length, ffebld_left (expr));
2096
2097         if (item == error_mark_node || *length == error_mark_node)
2098           {
2099             item = *length = error_mark_node;
2100             break;
2101           }
2102
2103         array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
2104
2105         /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF.  */
2106
2107         if (start == NULL)
2108           {
2109             if (end == NULL)
2110               ;
2111             else
2112               {
2113                 end_tree = ffecom_expr (end);
2114                 if (flag_bounds_check)
2115                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2116                                                       char_name);
2117                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2118                                     end_tree);
2119
2120                 if (end_tree == error_mark_node)
2121                   {
2122                     item = *length = error_mark_node;
2123                     break;
2124                   }
2125
2126                 *length = end_tree;
2127               }
2128           }
2129         else
2130           {
2131             start_tree = ffecom_expr (start);
2132             if (flag_bounds_check)
2133               start_tree = ffecom_subscript_check_ (array, start_tree, 0, 0,
2134                                                     char_name);
2135             start_tree = convert (ffecom_f2c_ftnlen_type_node,
2136                                   start_tree);
2137
2138             if (start_tree == error_mark_node)
2139               {
2140                 item = *length = error_mark_node;
2141                 break;
2142               }
2143
2144             start_tree = ffecom_save_tree (start_tree);
2145
2146             item = ffecom_2 (PLUS_EXPR, TREE_TYPE (item),
2147                              item,
2148                              ffecom_2 (MINUS_EXPR,
2149                                        TREE_TYPE (start_tree),
2150                                        start_tree,
2151                                        ffecom_f2c_ftnlen_one_node));
2152
2153             if (end == NULL)
2154               {
2155                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2156                                     ffecom_f2c_ftnlen_one_node,
2157                                     ffecom_2 (MINUS_EXPR,
2158                                               ffecom_f2c_ftnlen_type_node,
2159                                               *length,
2160                                               start_tree));
2161               }
2162             else
2163               {
2164                 end_tree = ffecom_expr (end);
2165                 if (flag_bounds_check)
2166                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2167                                                       char_name);
2168                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2169                                     end_tree);
2170
2171                 if (end_tree == error_mark_node)
2172                   {
2173                     item = *length = error_mark_node;
2174                     break;
2175                   }
2176
2177                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2178                                     ffecom_f2c_ftnlen_one_node,
2179                                     ffecom_2 (MINUS_EXPR,
2180                                               ffecom_f2c_ftnlen_type_node,
2181                                               end_tree, start_tree));
2182               }
2183           }
2184       }
2185       break;
2186
2187     case FFEBLD_opFUNCREF:
2188       {
2189         ffesymbol s = ffebld_symter (ffebld_left (expr));
2190         tree tempvar;
2191         tree args;
2192         ffetargetCharacterSize size = ffeinfo_size (ffebld_info (expr));
2193         ffecomGfrt ix;
2194
2195         if (size == FFETARGET_charactersizeNONE)
2196           /* ~~Kludge alert!  This should someday be fixed. */
2197           size = 24;
2198
2199         *length = build_int_2 (size, 0);
2200         TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2201
2202         if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
2203             == FFEINFO_whereINTRINSIC)
2204           {
2205             if (size == 1)
2206               {
2207                 /* Invocation of an intrinsic returning CHARACTER*1.  */
2208                 item = ffecom_expr_intrinsic_ (expr, NULL_TREE,
2209                                                NULL, NULL);
2210                 break;
2211               }
2212             ix = ffeintrin_gfrt_direct (ffebld_symter_implementation (ffebld_left (expr)));
2213             assert (ix != FFECOM_gfrt);
2214             item = ffecom_gfrt_tree_ (ix);
2215           }
2216         else
2217           {
2218             ix = FFECOM_gfrt;
2219             item = ffesymbol_hook (s).decl_tree;
2220             if (item == NULL_TREE)
2221               {
2222                 s = ffecom_sym_transform_ (s);
2223                 item = ffesymbol_hook (s).decl_tree;
2224               }
2225             if (item == error_mark_node)
2226               {
2227                 item = *length = error_mark_node;
2228                 break;
2229               }
2230
2231             if (!ffesymbol_hook (s).addr)
2232               item = ffecom_1_fn (item);
2233           }
2234
2235 #ifdef HOHO
2236         tempvar = ffecom_push_tempvar (char_type_node, size, -1, TRUE);
2237 #else
2238         tempvar = ffebld_nonter_hook (expr);
2239         assert (tempvar);
2240 #endif
2241         tempvar = ffecom_1 (ADDR_EXPR,
2242                             build_pointer_type (TREE_TYPE (tempvar)),
2243                             tempvar);
2244
2245         args = build_tree_list (NULL_TREE, tempvar);
2246
2247         if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)       /* Sfunc args by value. */
2248           TREE_CHAIN (args) = ffecom_list_expr (ffebld_right (expr));
2249         else
2250           {
2251             TREE_CHAIN (args) = build_tree_list (NULL_TREE, *length);
2252             if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
2253               {
2254                 TREE_CHAIN (TREE_CHAIN (args))
2255                   = ffecom_arglist_expr_ (ffecom_gfrt_args_ (ix),
2256                                           ffebld_right (expr));
2257               }
2258             else
2259               {
2260                 TREE_CHAIN (TREE_CHAIN (args))
2261                   = ffecom_list_ptr_to_expr (ffebld_right (expr));
2262               }
2263           }
2264
2265         item = ffecom_3s (CALL_EXPR,
2266                           TREE_TYPE (TREE_TYPE (TREE_TYPE (item))),
2267                           item, args, NULL_TREE);
2268         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item,
2269                          tempvar);
2270       }
2271       break;
2272
2273     case FFEBLD_opCONVERT:
2274
2275       ffecom_char_args_ (&item, length, ffebld_left (expr));
2276
2277       if (item == error_mark_node || *length == error_mark_node)
2278         {
2279           item = *length = error_mark_node;
2280           break;
2281         }
2282
2283       if ((ffebld_size_known (ffebld_left (expr))
2284            == FFETARGET_charactersizeNONE)
2285           || (ffebld_size_known (ffebld_left (expr)) < (ffebld_size (expr))))
2286         {                       /* Possible blank-padding needed, copy into
2287                                    temporary. */
2288           tree tempvar;
2289           tree args;
2290           tree newlen;
2291
2292 #ifdef HOHO
2293           tempvar = ffecom_make_tempvar (char_type_node,
2294                                          ffebld_size (expr), -1);
2295 #else
2296           tempvar = ffebld_nonter_hook (expr);
2297           assert (tempvar);
2298 #endif
2299           tempvar = ffecom_1 (ADDR_EXPR,
2300                               build_pointer_type (TREE_TYPE (tempvar)),
2301                               tempvar);
2302
2303           newlen = build_int_2 (ffebld_size (expr), 0);
2304           TREE_TYPE (newlen) = ffecom_f2c_ftnlen_type_node;
2305
2306           args = build_tree_list (NULL_TREE, tempvar);
2307           TREE_CHAIN (args) = build_tree_list (NULL_TREE, item);
2308           TREE_CHAIN (TREE_CHAIN (args)) = build_tree_list (NULL_TREE, newlen);
2309           TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args)))
2310             = build_tree_list (NULL_TREE, *length);
2311
2312           item = ffecom_call_gfrt (FFECOM_gfrtCOPY, args, NULL_TREE);
2313           TREE_SIDE_EFFECTS (item) = 1;
2314           item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), fold (item),
2315                            tempvar);
2316           *length = newlen;
2317         }
2318       else
2319         {                       /* Just truncate the length. */
2320           *length = build_int_2 (ffebld_size (expr), 0);
2321           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2322         }
2323       break;
2324
2325     default:
2326       assert ("bad op for single char arg expr" == NULL);
2327       item = NULL_TREE;
2328       break;
2329     }
2330
2331   *xitem = item;
2332 }
2333 #endif
2334
2335 /* Check the size of the type to be sure it doesn't overflow the
2336    "portable" capacities of the compiler back end.  `dummy' types
2337    can generally overflow the normal sizes as long as the computations
2338    themselves don't overflow.  A particular target of the back end
2339    must still enforce its size requirements, though, and the back
2340    end takes care of this in stor-layout.c.  */
2341
2342 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2343 static tree
2344 ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy)
2345 {
2346   if (TREE_CODE (type) == ERROR_MARK)
2347     return type;
2348
2349   if (TYPE_SIZE (type) == NULL_TREE)
2350     return type;
2351
2352   if (TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST)
2353     return type;
2354
2355   if ((tree_int_cst_sgn (TYPE_SIZE (type)) < 0)
2356       || (!dummy && (((TREE_INT_CST_HIGH (TYPE_SIZE (type)) != 0))
2357                      || TREE_OVERFLOW (TYPE_SIZE (type)))))
2358     {
2359       ffebad_start (FFEBAD_ARRAY_LARGE);
2360       ffebad_string (ffesymbol_text (s));
2361       ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
2362       ffebad_finish ();
2363
2364       return error_mark_node;
2365     }
2366
2367   return type;
2368 }
2369 #endif
2370
2371 /* Builds a length argument (PARM_DECL).  Also wraps type in an array type
2372    where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
2373    known, length_arg if not known (FFETARGET_charactersizeNONE).  */
2374
2375 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2376 static tree
2377 ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s)
2378 {
2379   ffetargetCharacterSize sz = ffesymbol_size (s);
2380   tree highval;
2381   tree tlen;
2382   tree type = *xtype;
2383
2384   if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
2385     tlen = NULL_TREE;           /* A statement function, no length passed. */
2386   else
2387     {
2388       if (ffesymbol_where (s) == FFEINFO_whereDUMMY)
2389         tlen = ffecom_get_invented_identifier ("__g77_length_%s",
2390                                                ffesymbol_text (s));
2391       else
2392         tlen = ffecom_get_invented_identifier ("__g77_%s", "length");
2393       tlen = build_decl (PARM_DECL, tlen, ffecom_f2c_ftnlen_type_node);
2394 #if BUILT_FOR_270
2395       DECL_ARTIFICIAL (tlen) = 1;
2396 #endif
2397     }
2398
2399   if (sz == FFETARGET_charactersizeNONE)
2400     {
2401       assert (tlen != NULL_TREE);
2402       highval = variable_size (tlen);
2403     }
2404   else
2405     {
2406       highval = build_int_2 (sz, 0);
2407       TREE_TYPE (highval) = ffecom_f2c_ftnlen_type_node;
2408     }
2409
2410   type = build_array_type (type,
2411                            build_range_type (ffecom_f2c_ftnlen_type_node,
2412                                              ffecom_f2c_ftnlen_one_node,
2413                                              highval));
2414
2415   *xtype = type;
2416   return tlen;
2417 }
2418
2419 #endif
2420 /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
2421
2422    ffecomConcatList_ catlist;
2423    ffebld expr;  // expr of CHARACTER basictype.
2424    ffetargetCharacterSize max;  // max chars to gather or _...NONE if no max
2425    catlist = ffecom_concat_list_gather_(catlist,expr,max);
2426
2427    Scans expr for character subexpressions, updates and returns catlist
2428    accordingly.  */
2429
2430 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2431 static ffecomConcatList_
2432 ffecom_concat_list_gather_ (ffecomConcatList_ catlist, ffebld expr,
2433                             ffetargetCharacterSize max)
2434 {
2435   ffetargetCharacterSize sz;
2436
2437 recurse:                        /* :::::::::::::::::::: */
2438
2439   if (expr == NULL)
2440     return catlist;
2441
2442   if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen >= max))
2443     return catlist;             /* Don't append any more items. */
2444
2445   switch (ffebld_op (expr))
2446     {
2447     case FFEBLD_opCONTER:
2448     case FFEBLD_opSYMTER:
2449     case FFEBLD_opARRAYREF:
2450     case FFEBLD_opFUNCREF:
2451     case FFEBLD_opSUBSTR:
2452     case FFEBLD_opCONVERT:      /* Callers should strip this off beforehand
2453                                    if they don't need to preserve it. */
2454       if (catlist.count == catlist.max)
2455         {                       /* Make a (larger) list. */
2456           ffebld *newx;
2457           int newmax;
2458
2459           newmax = (catlist.max == 0) ? 8 : catlist.max * 2;
2460           newx = malloc_new_ks (malloc_pool_image (), "catlist",
2461                                 newmax * sizeof (newx[0]));
2462           if (catlist.max != 0)
2463             {
2464               memcpy (newx, catlist.exprs, catlist.max * sizeof (newx[0]));
2465               malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2466                               catlist.max * sizeof (newx[0]));
2467             }
2468           catlist.max = newmax;
2469           catlist.exprs = newx;
2470         }
2471       if ((sz = ffebld_size_known (expr)) != FFETARGET_charactersizeNONE)
2472         catlist.minlen += sz;
2473       else
2474         ++catlist.minlen;       /* Not true for F90; can be 0 length. */
2475       if ((sz = ffebld_size_max (expr)) == FFETARGET_charactersizeNONE)
2476         catlist.maxlen = sz;
2477       else
2478         catlist.maxlen += sz;
2479       if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen > max))
2480         {                       /* This item overlaps (or is beyond) the end
2481                                    of the destination. */
2482           switch (ffebld_op (expr))
2483             {
2484             case FFEBLD_opCONTER:
2485             case FFEBLD_opSYMTER:
2486             case FFEBLD_opARRAYREF:
2487             case FFEBLD_opFUNCREF:
2488             case FFEBLD_opSUBSTR:
2489               /* ~~Do useful truncations here. */
2490               break;
2491
2492             default:
2493               assert ("op changed or inconsistent switches!" == NULL);
2494               break;
2495             }
2496         }
2497       catlist.exprs[catlist.count++] = expr;
2498       return catlist;
2499
2500     case FFEBLD_opPAREN:
2501       expr = ffebld_left (expr);
2502       goto recurse;             /* :::::::::::::::::::: */
2503
2504     case FFEBLD_opCONCATENATE:
2505       catlist = ffecom_concat_list_gather_ (catlist, ffebld_left (expr), max);
2506       expr = ffebld_right (expr);
2507       goto recurse;             /* :::::::::::::::::::: */
2508
2509 #if 0                           /* Breaks passing small actual arg to larger
2510                                    dummy arg of sfunc */
2511     case FFEBLD_opCONVERT:
2512       expr = ffebld_left (expr);
2513       {
2514         ffetargetCharacterSize cmax;
2515
2516         cmax = catlist.len + ffebld_size_known (expr);
2517
2518         if ((max == FFETARGET_charactersizeNONE) || (max > cmax))
2519           max = cmax;
2520       }
2521       goto recurse;             /* :::::::::::::::::::: */
2522 #endif
2523
2524     case FFEBLD_opANY:
2525       return catlist;
2526
2527     default:
2528       assert ("bad op in _gather_" == NULL);
2529       return catlist;
2530     }
2531 }
2532
2533 #endif
2534 /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
2535
2536    ffecomConcatList_ catlist;
2537    ffecom_concat_list_kill_(catlist);
2538
2539    Anything allocated within the list info is deallocated.  */
2540
2541 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2542 static void
2543 ffecom_concat_list_kill_ (ffecomConcatList_ catlist)
2544 {
2545   if (catlist.max != 0)
2546     malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2547                     catlist.max * sizeof (catlist.exprs[0]));
2548 }
2549
2550 #endif
2551 /* Make list of concatenated string exprs.
2552
2553    Returns a flattened list of concatenated subexpressions given a
2554    tree of such expressions.  */
2555
2556 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2557 static ffecomConcatList_
2558 ffecom_concat_list_new_ (ffebld expr, ffetargetCharacterSize max)
2559 {
2560   ffecomConcatList_ catlist;
2561
2562   catlist.maxlen = catlist.minlen = catlist.max = catlist.count = 0;
2563   return ffecom_concat_list_gather_ (catlist, expr, max);
2564 }
2565
2566 #endif
2567
2568 /* Provide some kind of useful info on member of aggregate area,
2569    since current g77/gcc technology does not provide debug info
2570    on these members.  */
2571
2572 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2573 static void
2574 ffecom_debug_kludge_ (tree aggr, const char *aggr_type, ffesymbol member,
2575                       tree member_type UNUSED, ffetargetOffset offset)
2576 {
2577   tree value;
2578   tree decl;
2579   int len;
2580   char *buff;
2581   char space[120];
2582 #if 0
2583   tree type_id;
2584
2585   for (type_id = member_type;
2586        TREE_CODE (type_id) != IDENTIFIER_NODE;
2587        )
2588     {
2589       switch (TREE_CODE (type_id))
2590         {
2591         case INTEGER_TYPE:
2592         case REAL_TYPE:
2593           type_id = TYPE_NAME (type_id);
2594           break;
2595
2596         case ARRAY_TYPE:
2597         case COMPLEX_TYPE:
2598           type_id = TREE_TYPE (type_id);
2599           break;
2600
2601         default:
2602           assert ("no IDENTIFIER_NODE for type!" == NULL);
2603           type_id = error_mark_node;
2604           break;
2605         }
2606     }
2607 #endif
2608
2609   if (ffecom_transform_only_dummies_
2610       || !ffe_is_debug_kludge ())
2611     return;     /* Can't do this yet, maybe later. */
2612
2613   len = 60
2614     + strlen (aggr_type)
2615     + IDENTIFIER_LENGTH (DECL_NAME (aggr));
2616 #if 0
2617     + IDENTIFIER_LENGTH (type_id);
2618 #endif
2619
2620   if (((size_t) len) >= ARRAY_SIZE (space))
2621     buff = malloc_new_ks (malloc_pool_image (), "debug_kludge", len + 1);
2622   else
2623     buff = &space[0];
2624
2625   sprintf (&buff[0], "At (%s) `%s' plus %ld bytes",
2626            aggr_type,
2627            IDENTIFIER_POINTER (DECL_NAME (aggr)),
2628            (long int) offset);
2629
2630   value = build_string (len, buff);
2631   TREE_TYPE (value)
2632     = build_type_variant (build_array_type (char_type_node,
2633                                             build_range_type
2634                                             (integer_type_node,
2635                                              integer_one_node,
2636                                              build_int_2 (strlen (buff), 0))),
2637                           1, 0);
2638   decl = build_decl (VAR_DECL,
2639                      ffecom_get_identifier_ (ffesymbol_text (member)),
2640                      TREE_TYPE (value));
2641   TREE_CONSTANT (decl) = 1;
2642   TREE_STATIC (decl) = 1;
2643   DECL_INITIAL (decl) = error_mark_node;
2644   DECL_IN_SYSTEM_HEADER (decl) = 1;     /* Don't let -Wunused complain. */
2645   decl = start_decl (decl, FALSE);
2646   finish_decl (decl, value, FALSE);
2647
2648   if (buff != &space[0])
2649     malloc_kill_ks (malloc_pool_image (), buff, len + 1);
2650 }
2651 #endif
2652
2653 /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
2654
2655    ffesymbol fn;  // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
2656    int i;  // entry# for this entrypoint (used by master fn)
2657    ffecom_do_entrypoint_(s,i);
2658
2659    Makes a public entry point that calls our private master fn (already
2660    compiled).  */
2661
2662 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2663 static void
2664 ffecom_do_entry_ (ffesymbol fn, int entrynum)
2665 {
2666   ffebld item;
2667   tree type;                    /* Type of function. */
2668   tree multi_retval;            /* Var holding return value (union). */
2669   tree result;                  /* Var holding result. */
2670   ffeinfoBasictype bt;
2671   ffeinfoKindtype kt;
2672   ffeglobal g;
2673   ffeglobalType gt;
2674   bool charfunc;                /* All entry points return same type
2675                                    CHARACTER. */
2676   bool cmplxfunc;               /* Use f2c way of returning COMPLEX. */
2677   bool multi;                   /* Master fn has multiple return types. */
2678   bool altreturning = FALSE;    /* This entry point has alternate returns. */
2679   int yes;
2680   int old_lineno = lineno;
2681   char *old_input_filename = input_filename;
2682
2683   input_filename = ffesymbol_where_filename (fn);
2684   lineno = ffesymbol_where_filelinenum (fn);
2685
2686   /* c-parse.y indeed does call suspend_momentary and not only ignores the
2687      return value, but also never calls resume_momentary, when starting an
2688      outer function (see "fndef:", "setspecs:", and so on).  So g77 does the
2689      same thing.  It shouldn't be a problem since start_function calls
2690      temporary_allocation, but it might be necessary.  If it causes a problem
2691      here, then maybe there's a bug lurking in gcc.  NOTE: This identical
2692      comment appears twice in thist file.  */
2693
2694   suspend_momentary ();
2695
2696   ffecom_doing_entry_ = TRUE;   /* Don't bother with array dimensions. */
2697
2698   switch (ffecom_primary_entry_kind_)
2699     {
2700     case FFEINFO_kindFUNCTION:
2701
2702       /* Determine actual return type for function. */
2703
2704       gt = FFEGLOBAL_typeFUNC;
2705       bt = ffesymbol_basictype (fn);
2706       kt = ffesymbol_kindtype (fn);
2707       if (bt == FFEINFO_basictypeNONE)
2708         {
2709           ffeimplic_establish_symbol (fn);
2710           if (ffesymbol_funcresult (fn) != NULL)
2711             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
2712           bt = ffesymbol_basictype (fn);
2713           kt = ffesymbol_kindtype (fn);
2714         }
2715
2716       if (bt == FFEINFO_basictypeCHARACTER)
2717         charfunc = TRUE, cmplxfunc = FALSE;
2718       else if ((bt == FFEINFO_basictypeCOMPLEX)
2719                && ffesymbol_is_f2c (fn))
2720         charfunc = FALSE, cmplxfunc = TRUE;
2721       else
2722         charfunc = cmplxfunc = FALSE;
2723
2724       if (charfunc)
2725         type = ffecom_tree_fun_type_void;
2726       else if (ffesymbol_is_f2c (fn))
2727         type = ffecom_tree_fun_type[bt][kt];
2728       else
2729         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
2730
2731       if ((type == NULL_TREE)
2732           || (TREE_TYPE (type) == NULL_TREE))
2733         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
2734
2735       multi = (ffecom_master_bt_ == FFEINFO_basictypeNONE);
2736       break;
2737
2738     case FFEINFO_kindSUBROUTINE:
2739       gt = FFEGLOBAL_typeSUBR;
2740       bt = FFEINFO_basictypeNONE;
2741       kt = FFEINFO_kindtypeNONE;
2742       if (ffecom_is_altreturning_)
2743         {                       /* Am _I_ altreturning? */
2744           for (item = ffesymbol_dummyargs (fn);
2745                item != NULL;
2746                item = ffebld_trail (item))
2747             {
2748               if (ffebld_op (ffebld_head (item)) == FFEBLD_opSTAR)
2749                 {
2750                   altreturning = TRUE;
2751                   break;
2752                 }
2753             }
2754           if (altreturning)
2755             type = ffecom_tree_subr_type;
2756           else
2757             type = ffecom_tree_fun_type_void;
2758         }
2759       else
2760         type = ffecom_tree_fun_type_void;
2761       charfunc = FALSE;
2762       cmplxfunc = FALSE;
2763       multi = FALSE;
2764       break;
2765
2766     default:
2767       assert ("say what??" == NULL);
2768       /* Fall through. */
2769     case FFEINFO_kindANY:
2770       gt = FFEGLOBAL_typeANY;
2771       bt = FFEINFO_basictypeNONE;
2772       kt = FFEINFO_kindtypeNONE;
2773       type = error_mark_node;
2774       charfunc = FALSE;
2775       cmplxfunc = FALSE;
2776       multi = FALSE;
2777       break;
2778     }
2779
2780   /* build_decl uses the current lineno and input_filename to set the decl
2781      source info.  So, I've putzed with ffestd and ffeste code to update that
2782      source info to point to the appropriate statement just before calling
2783      ffecom_do_entrypoint (which calls this fn).  */
2784
2785   start_function (ffecom_get_external_identifier_ (fn),
2786                   type,
2787                   0,            /* nested/inline */
2788                   1);           /* TREE_PUBLIC */
2789
2790   if (((g = ffesymbol_global (fn)) != NULL)
2791       && ((ffeglobal_type (g) == gt)
2792           || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
2793     {
2794       ffeglobal_set_hook (g, current_function_decl);
2795     }
2796
2797   /* Reset args in master arg list so they get retransitioned. */
2798
2799   for (item = ffecom_master_arglist_;
2800        item != NULL;
2801        item = ffebld_trail (item))
2802     {
2803       ffebld arg;
2804       ffesymbol s;
2805
2806       arg = ffebld_head (item);
2807       if (ffebld_op (arg) != FFEBLD_opSYMTER)
2808         continue;               /* Alternate return or some such thing. */
2809       s = ffebld_symter (arg);
2810       ffesymbol_hook (s).decl_tree = NULL_TREE;
2811       ffesymbol_hook (s).length_tree = NULL_TREE;
2812     }
2813
2814   /* Build dummy arg list for this entry point. */
2815
2816   yes = suspend_momentary ();
2817
2818   if (charfunc || cmplxfunc)
2819     {                           /* Prepend arg for where result goes. */
2820       tree type;
2821       tree length;
2822
2823       if (charfunc)
2824         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
2825       else
2826         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
2827
2828       result = ffecom_get_invented_identifier ("__g77_%s", "result");
2829
2830       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
2831
2832       if (charfunc)
2833         length = ffecom_char_enhance_arg_ (&type, fn);
2834       else
2835         length = NULL_TREE;     /* Not ref'd if !charfunc. */
2836
2837       type = build_pointer_type (type);
2838       result = build_decl (PARM_DECL, result, type);
2839
2840       push_parm_decl (result);
2841       ffecom_func_result_ = result;
2842
2843       if (charfunc)
2844         {
2845           push_parm_decl (length);
2846           ffecom_func_length_ = length;
2847         }
2848     }
2849   else
2850     result = DECL_RESULT (current_function_decl);
2851
2852   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn), FALSE);
2853
2854   resume_momentary (yes);
2855
2856   store_parm_decls (0);
2857
2858   ffecom_start_compstmt ();
2859   /* Disallow temp vars at this level.  */
2860   current_binding_level->prep_state = 2;
2861
2862   /* Make local var to hold return type for multi-type master fn. */
2863
2864   if (multi)
2865     {
2866       yes = suspend_momentary ();
2867
2868       multi_retval = ffecom_get_invented_identifier ("__g77_%s",
2869                                                      "multi_retval");
2870       multi_retval = build_decl (VAR_DECL, multi_retval,
2871                                  ffecom_multi_type_node_);
2872       multi_retval = start_decl (multi_retval, FALSE);
2873       finish_decl (multi_retval, NULL_TREE, FALSE);
2874
2875       resume_momentary (yes);
2876     }
2877   else
2878     multi_retval = NULL_TREE;   /* Not actually ref'd if !multi. */
2879
2880   /* Here we emit the actual code for the entry point. */
2881
2882   {
2883     ffebld list;
2884     ffebld arg;
2885     ffesymbol s;
2886     tree arglist = NULL_TREE;
2887     tree *plist = &arglist;
2888     tree prepend;
2889     tree call;
2890     tree actarg;
2891     tree master_fn;
2892
2893     /* Prepare actual arg list based on master arg list. */
2894
2895     for (list = ffecom_master_arglist_;
2896          list != NULL;
2897          list = ffebld_trail (list))
2898       {
2899         arg = ffebld_head (list);
2900         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2901           continue;
2902         s = ffebld_symter (arg);
2903         if (ffesymbol_hook (s).decl_tree == NULL_TREE
2904             || ffesymbol_hook (s).decl_tree == error_mark_node)
2905           actarg = null_pointer_node;   /* We don't have this arg. */
2906         else
2907           actarg = ffesymbol_hook (s).decl_tree;
2908         *plist = build_tree_list (NULL_TREE, actarg);
2909         plist = &TREE_CHAIN (*plist);
2910       }
2911
2912     /* This code appends the length arguments for character
2913        variables/arrays.  */
2914
2915     for (list = ffecom_master_arglist_;
2916          list != NULL;
2917          list = ffebld_trail (list))
2918       {
2919         arg = ffebld_head (list);
2920         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2921           continue;
2922         s = ffebld_symter (arg);
2923         if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
2924           continue;             /* Only looking for CHARACTER arguments. */
2925         if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
2926           continue;             /* Only looking for variables and arrays. */
2927         if (ffesymbol_hook (s).length_tree == NULL_TREE
2928             || ffesymbol_hook (s).length_tree == error_mark_node)
2929           actarg = ffecom_f2c_ftnlen_zero_node; /* We don't have this arg. */
2930         else
2931           actarg = ffesymbol_hook (s).length_tree;
2932         *plist = build_tree_list (NULL_TREE, actarg);
2933         plist = &TREE_CHAIN (*plist);
2934       }
2935
2936     /* Prepend character-value return info to actual arg list. */
2937
2938     if (charfunc)
2939       {
2940         prepend = build_tree_list (NULL_TREE, ffecom_func_result_);
2941         TREE_CHAIN (prepend)
2942           = build_tree_list (NULL_TREE, ffecom_func_length_);
2943         TREE_CHAIN (TREE_CHAIN (prepend)) = arglist;
2944         arglist = prepend;
2945       }
2946
2947     /* Prepend multi-type return value to actual arg list. */
2948
2949     if (multi)
2950       {
2951         prepend
2952           = build_tree_list (NULL_TREE,
2953                              ffecom_1 (ADDR_EXPR,
2954                               build_pointer_type (TREE_TYPE (multi_retval)),
2955                                        multi_retval));
2956         TREE_CHAIN (prepend) = arglist;
2957         arglist = prepend;
2958       }
2959
2960     /* Prepend my entry-point number to the actual arg list. */
2961
2962     prepend = build_tree_list (NULL_TREE, build_int_2 (entrynum, 0));
2963     TREE_CHAIN (prepend) = arglist;
2964     arglist = prepend;
2965
2966     /* Build the call to the master function. */
2967
2968     master_fn = ffecom_1_fn (ffecom_previous_function_decl_);
2969     call = ffecom_3s (CALL_EXPR,
2970                       TREE_TYPE (TREE_TYPE (TREE_TYPE (master_fn))),
2971                       master_fn, arglist, NULL_TREE);
2972
2973     /* Decide whether the master function is a function or subroutine, and
2974        handle the return value for my entry point. */
2975
2976     if (charfunc || ((ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
2977                      && !altreturning))
2978       {
2979         expand_expr_stmt (call);
2980         expand_null_return ();
2981       }
2982     else if (multi && cmplxfunc)
2983       {
2984         expand_expr_stmt (call);
2985         result
2986           = ffecom_1 (INDIRECT_REF,
2987                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2988                       result);
2989         result = ffecom_modify (NULL_TREE, result,
2990                                 ffecom_2 (COMPONENT_REF, TREE_TYPE (result),
2991                                           multi_retval,
2992                                           ffecom_multi_fields_[bt][kt]));
2993         expand_expr_stmt (result);
2994         expand_null_return ();
2995       }
2996     else if (multi)
2997       {
2998         expand_expr_stmt (call);
2999         result
3000           = ffecom_modify (NULL_TREE, result,
3001                            convert (TREE_TYPE (result),
3002                                     ffecom_2 (COMPONENT_REF,
3003                                               ffecom_tree_type[bt][kt],
3004                                               multi_retval,
3005                                               ffecom_multi_fields_[bt][kt])));
3006         expand_return (result);
3007       }
3008     else if (cmplxfunc)
3009       {
3010         result
3011           = ffecom_1 (INDIRECT_REF,
3012                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
3013                       result);
3014         result = ffecom_modify (NULL_TREE, result, call);
3015         expand_expr_stmt (result);
3016         expand_null_return ();
3017       }
3018     else
3019       {
3020         result = ffecom_modify (NULL_TREE,
3021                                 result,
3022                                 convert (TREE_TYPE (result),
3023                                          call));
3024         expand_return (result);
3025       }
3026
3027     clear_momentary ();
3028   }
3029
3030   ffecom_end_compstmt ();
3031
3032   finish_function (0);
3033
3034   lineno = old_lineno;
3035   input_filename = old_input_filename;
3036
3037   ffecom_doing_entry_ = FALSE;
3038 }
3039
3040 #endif
3041 /* Transform expr into gcc tree with possible destination
3042
3043    Recursive descent on expr while making corresponding tree nodes and
3044    attaching type info and such.  If destination supplied and compatible
3045    with temporary that would be made in certain cases, temporary isn't
3046    made, destination used instead, and dest_used flag set TRUE.  */
3047
3048 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3049 static tree
3050 ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
3051               bool *dest_used, bool assignp, bool widenp)
3052 {
3053   tree item;
3054   tree list;
3055   tree args;
3056   ffeinfoBasictype bt;
3057   ffeinfoKindtype kt;
3058   tree t;
3059   tree dt;                      /* decl_tree for an ffesymbol. */
3060   tree tree_type, tree_type_x;
3061   tree left, right;
3062   ffesymbol s;
3063   enum tree_code code;
3064
3065   assert (expr != NULL);
3066
3067   if (dest_used != NULL)
3068     *dest_used = FALSE;
3069
3070   bt = ffeinfo_basictype (ffebld_info (expr));
3071   kt = ffeinfo_kindtype (ffebld_info (expr));
3072   tree_type = ffecom_tree_type[bt][kt];
3073
3074   /* Widen integral arithmetic as desired while preserving signedness.  */
3075   tree_type_x = NULL_TREE;
3076   if (widenp && tree_type
3077       && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
3078       && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
3079     tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
3080
3081   switch (ffebld_op (expr))
3082     {
3083     case FFEBLD_opACCTER:
3084       {
3085         ffebitCount i;
3086         ffebit bits = ffebld_accter_bits (expr);
3087         ffetargetOffset source_offset = 0;
3088         ffetargetOffset dest_offset = ffebld_accter_pad (expr);
3089         tree purpose;
3090
3091         assert (dest_offset == 0
3092                 || (bt == FFEINFO_basictypeCHARACTER
3093                     && kt == FFEINFO_kindtypeCHARACTER1));
3094
3095         list = item = NULL;
3096         for (;;)
3097           {
3098             ffebldConstantUnion cu;
3099             ffebitCount length;
3100             bool value;
3101             ffebldConstantArray ca = ffebld_accter (expr);
3102
3103             ffebit_test (bits, source_offset, &value, &length);
3104             if (length == 0)
3105               break;
3106
3107             if (value)
3108               {
3109                 for (i = 0; i < length; ++i)
3110                   {
3111                     cu = ffebld_constantarray_get (ca, bt, kt,
3112                                                    source_offset + i);
3113
3114                     t = ffecom_constantunion (&cu, bt, kt, tree_type);
3115
3116                     if (i == 0
3117                         && dest_offset != 0)
3118                       purpose = build_int_2 (dest_offset, 0);
3119                     else
3120                       purpose = NULL_TREE;
3121
3122                     if (list == NULL_TREE)
3123                       list = item = build_tree_list (purpose, t);
3124                     else
3125                       {
3126                         TREE_CHAIN (item) = build_tree_list (purpose, t);
3127                         item = TREE_CHAIN (item);
3128                       }
3129                   }
3130               }
3131             source_offset += length;
3132             dest_offset += length;
3133           }
3134       }
3135
3136       item = build_int_2 ((ffebld_accter_size (expr)
3137                            + ffebld_accter_pad (expr)) - 1, 0);
3138       ffebit_kill (ffebld_accter_bits (expr));
3139       TREE_TYPE (item) = ffecom_integer_type_node;
3140       item
3141         = build_array_type
3142           (tree_type,
3143            build_range_type (ffecom_integer_type_node,
3144                              ffecom_integer_zero_node,
3145                              item));
3146       list = build (CONSTRUCTOR, item, NULL_TREE, list);
3147       TREE_CONSTANT (list) = 1;
3148       TREE_STATIC (list) = 1;
3149       return list;
3150
3151     case FFEBLD_opARRTER:
3152       {
3153         ffetargetOffset i;
3154
3155         list = NULL_TREE;
3156         if (ffebld_arrter_pad (expr) == 0)
3157           item = NULL_TREE;
3158         else
3159           {
3160             assert (bt == FFEINFO_basictypeCHARACTER
3161                     && kt == FFEINFO_kindtypeCHARACTER1);
3162
3163             /* Becomes PURPOSE first time through loop.  */
3164             item = build_int_2 (ffebld_arrter_pad (expr), 0);
3165           }
3166
3167         for (i = 0; i < ffebld_arrter_size (expr); ++i)
3168           {
3169             ffebldConstantUnion cu
3170             = ffebld_constantarray_get (ffebld_arrter (expr), bt, kt, i);
3171
3172             t = ffecom_constantunion (&cu, bt, kt, tree_type);
3173
3174             if (list == NULL_TREE)
3175               /* Assume item is PURPOSE first time through loop.  */
3176               list = item = build_tree_list (item, t);
3177             else
3178               {
3179                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
3180                 item = TREE_CHAIN (item);
3181               }
3182           }
3183       }
3184
3185       item = build_int_2 ((ffebld_arrter_size (expr)
3186                           + ffebld_arrter_pad (expr)) - 1, 0);
3187       TREE_TYPE (item) = ffecom_integer_type_node;
3188       item
3189         = build_array_type
3190           (tree_type,
3191            build_range_type (ffecom_integer_type_node,
3192                              ffecom_integer_zero_node,
3193                              item));
3194       list = build (CONSTRUCTOR, item, NULL_TREE, list);
3195       TREE_CONSTANT (list) = 1;
3196       TREE_STATIC (list) = 1;
3197       return list;
3198
3199     case FFEBLD_opCONTER:
3200       assert (ffebld_conter_pad (expr) == 0);
3201       item
3202         = ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr)),
3203                                 bt, kt, tree_type);
3204       return item;
3205
3206     case FFEBLD_opSYMTER:
3207       if ((ffebld_symter_generic (expr) != FFEINTRIN_genNONE)
3208           || (ffebld_symter_specific (expr) != FFEINTRIN_specNONE))
3209         return ffecom_ptr_to_expr (expr);       /* Same as %REF(intrinsic). */
3210       s = ffebld_symter (expr);
3211       t = ffesymbol_hook (s).decl_tree;
3212
3213       if (assignp)
3214         {                       /* ASSIGN'ed-label expr. */
3215           if (ffe_is_ugly_assign ())
3216             {
3217               /* User explicitly wants ASSIGN'ed variables to be at the same
3218                  memory address as the variables when used in non-ASSIGN
3219                  contexts.  That can make old, arcane, non-standard code
3220                  work, but don't try to do it when a pointer wouldn't fit
3221                  in the normal variable (take other approach, and warn,
3222                  instead).  */
3223
3224               if (t == NULL_TREE)
3225                 {
3226                   s = ffecom_sym_transform_ (s);
3227                   t = ffesymbol_hook (s).decl_tree;
3228                   assert (t != NULL_TREE);
3229                 }
3230
3231               if (t == error_mark_node)
3232                 return t;
3233
3234               if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t)))
3235                   >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
3236                 {
3237                   if (ffesymbol_hook (s).addr)
3238                     t = ffecom_1 (INDIRECT_REF,
3239                                   TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3240                   return t;
3241                 }
3242
3243               if (ffesymbol_hook (s).assign_tree == NULL_TREE)
3244                 {
3245                   ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling",
3246                                     FFEBAD_severityWARNING);
3247                   ffebad_string (ffesymbol_text (s));
3248                   ffebad_here (0, ffesymbol_where_line (s),
3249                                ffesymbol_where_column (s));
3250                   ffebad_finish ();
3251                 }
3252             }
3253
3254           /* Don't use the normal variable's tree for ASSIGN, though mark
3255              it as in the system header (housekeeping).  Use an explicit,
3256              specially created sibling that is known to be wide enough
3257              to hold pointers to labels.  */
3258
3259           if (t != NULL_TREE
3260               && TREE_CODE (t) == VAR_DECL)
3261             DECL_IN_SYSTEM_HEADER (t) = 1;      /* Don't let -Wunused complain. */
3262
3263           t = ffesymbol_hook (s).assign_tree;
3264           if (t == NULL_TREE)
3265             {
3266               s = ffecom_sym_transform_assign_ (s);
3267               t = ffesymbol_hook (s).assign_tree;
3268               assert (t != NULL_TREE);
3269             }
3270         }
3271       else
3272         {
3273           if (t == NULL_TREE)
3274             {
3275               s = ffecom_sym_transform_ (s);
3276               t = ffesymbol_hook (s).decl_tree;
3277               assert (t != NULL_TREE);
3278             }
3279           if (ffesymbol_hook (s).addr)
3280             t = ffecom_1 (INDIRECT_REF,
3281                           TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3282         }
3283       return t;
3284
3285     case FFEBLD_opARRAYREF:
3286       return ffecom_arrayref_ (NULL_TREE, expr, 0);
3287
3288     case FFEBLD_opUPLUS:
3289       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3290       return ffecom_1 (NOP_EXPR, tree_type, left);
3291
3292     case FFEBLD_opPAREN:
3293       /* ~~~Make sure Fortran rules respected here */
3294       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3295       return ffecom_1 (NOP_EXPR, tree_type, left);
3296
3297     case FFEBLD_opUMINUS:
3298       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3299       if (tree_type_x)
3300         {
3301           tree_type = tree_type_x;
3302           left = convert (tree_type, left);
3303         }
3304       return ffecom_1 (NEGATE_EXPR, tree_type, left);
3305
3306     case FFEBLD_opADD:
3307       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3308       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3309       if (tree_type_x)
3310         {
3311           tree_type = tree_type_x;
3312           left = convert (tree_type, left);
3313           right = convert (tree_type, right);
3314         }
3315       return ffecom_2 (PLUS_EXPR, tree_type, left, right);
3316
3317     case FFEBLD_opSUBTRACT:
3318       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3319       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3320       if (tree_type_x)
3321         {
3322           tree_type = tree_type_x;
3323           left = convert (tree_type, left);
3324           right = convert (tree_type, right);
3325         }
3326       return ffecom_2 (MINUS_EXPR, tree_type, left, right);
3327
3328     case FFEBLD_opMULTIPLY:
3329       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3330       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3331       if (tree_type_x)
3332         {
3333           tree_type = tree_type_x;
3334           left = convert (tree_type, left);
3335           right = convert (tree_type, right);
3336         }
3337       return ffecom_2 (MULT_EXPR, tree_type, left, right);
3338
3339     case FFEBLD_opDIVIDE:
3340       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3341       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3342       if (tree_type_x)
3343         {
3344           tree_type = tree_type_x;
3345           left = convert (tree_type, left);
3346           right = convert (tree_type, right);
3347         }
3348       return ffecom_tree_divide_ (tree_type, left, right,
3349                                   dest_tree, dest, dest_used,
3350                                   ffebld_nonter_hook (expr));
3351
3352     case FFEBLD_opPOWER:
3353       {
3354         ffebld left = ffebld_left (expr);
3355         ffebld right = ffebld_right (expr);
3356         ffecomGfrt code;
3357         ffeinfoKindtype rtkt;
3358         ffeinfoKindtype ltkt;
3359
3360         switch (ffeinfo_basictype (ffebld_info (right)))
3361           {
3362           case FFEINFO_basictypeINTEGER:
3363             if (1 || optimize)
3364               {
3365                 item = ffecom_expr_power_integer_ (expr);
3366                 if (item != NULL_TREE)
3367                   return item;
3368               }
3369
3370             rtkt = FFEINFO_kindtypeINTEGER1;
3371             switch (ffeinfo_basictype (ffebld_info (left)))
3372               {
3373               case FFEINFO_basictypeINTEGER:
3374                 if ((ffeinfo_kindtype (ffebld_info (left))
3375                     == FFEINFO_kindtypeINTEGER4)
3376                     || (ffeinfo_kindtype (ffebld_info (right))
3377                         == FFEINFO_kindtypeINTEGER4))
3378                   {
3379                     code = FFECOM_gfrtPOW_QQ;
3380                     ltkt = FFEINFO_kindtypeINTEGER4;
3381                     rtkt = FFEINFO_kindtypeINTEGER4;
3382                   }
3383                 else
3384                   {
3385                     code = FFECOM_gfrtPOW_II;
3386                     ltkt = FFEINFO_kindtypeINTEGER1;
3387                   }
3388                 break;
3389
3390               case FFEINFO_basictypeREAL:
3391                 if (ffeinfo_kindtype (ffebld_info (left))
3392                     == FFEINFO_kindtypeREAL1)
3393                   {
3394                     code = FFECOM_gfrtPOW_RI;
3395                     ltkt = FFEINFO_kindtypeREAL1;
3396                   }
3397                 else
3398                   {
3399                     code = FFECOM_gfrtPOW_DI;
3400                     ltkt = FFEINFO_kindtypeREAL2;
3401                   }
3402                 break;
3403
3404               case FFEINFO_basictypeCOMPLEX:
3405                 if (ffeinfo_kindtype (ffebld_info (left))
3406                     == FFEINFO_kindtypeREAL1)
3407                   {
3408                     code = FFECOM_gfrtPOW_CI;   /* Overlapping result okay. */
3409                     ltkt = FFEINFO_kindtypeREAL1;
3410                   }
3411                 else
3412                   {
3413                     code = FFECOM_gfrtPOW_ZI;   /* Overlapping result okay. */
3414                     ltkt = FFEINFO_kindtypeREAL2;
3415                   }
3416                 break;
3417
3418               default:
3419                 assert ("bad pow_*i" == NULL);
3420                 code = FFECOM_gfrtPOW_CI;       /* Overlapping result okay. */
3421                 ltkt = FFEINFO_kindtypeREAL1;
3422                 break;
3423               }
3424             if (ffeinfo_kindtype (ffebld_info (left)) != ltkt)
3425               left = ffeexpr_convert (left, NULL, NULL,
3426                                       ffeinfo_basictype (ffebld_info (left)),
3427                                       ltkt, 0,
3428                                       FFETARGET_charactersizeNONE,
3429                                       FFEEXPR_contextLET);
3430             if (ffeinfo_kindtype (ffebld_info (right)) != rtkt)
3431               right = ffeexpr_convert (right, NULL, NULL,
3432                                        FFEINFO_basictypeINTEGER,
3433                                        rtkt, 0,
3434                                        FFETARGET_charactersizeNONE,
3435                                        FFEEXPR_contextLET);
3436             break;
3437
3438           case FFEINFO_basictypeREAL:
3439             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3440               left = ffeexpr_convert (left, NULL, NULL, FFEINFO_basictypeREAL,
3441                                       FFEINFO_kindtypeREALDOUBLE, 0,
3442                                       FFETARGET_charactersizeNONE,
3443                                       FFEEXPR_contextLET);
3444             if (ffeinfo_kindtype (ffebld_info (right))
3445                 == FFEINFO_kindtypeREAL1)
3446               right = ffeexpr_convert (right, NULL, NULL,
3447                                        FFEINFO_basictypeREAL,
3448                                        FFEINFO_kindtypeREALDOUBLE, 0,
3449                                        FFETARGET_charactersizeNONE,
3450                                        FFEEXPR_contextLET);
3451             code = FFECOM_gfrtPOW_DD;
3452             break;
3453
3454           case FFEINFO_basictypeCOMPLEX:
3455             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3456               left = ffeexpr_convert (left, NULL, NULL,
3457                                       FFEINFO_basictypeCOMPLEX,
3458                                       FFEINFO_kindtypeREALDOUBLE, 0,
3459                                       FFETARGET_charactersizeNONE,
3460                                       FFEEXPR_contextLET);
3461             if (ffeinfo_kindtype (ffebld_info (right))
3462                 == FFEINFO_kindtypeREAL1)
3463               right = ffeexpr_convert (right, NULL, NULL,
3464                                        FFEINFO_basictypeCOMPLEX,
3465                                        FFEINFO_kindtypeREALDOUBLE, 0,
3466                                        FFETARGET_charactersizeNONE,
3467                                        FFEEXPR_contextLET);
3468             code = FFECOM_gfrtPOW_ZZ;   /* Overlapping result okay. */
3469             break;
3470
3471           default:
3472             assert ("bad pow_x*" == NULL);
3473             code = FFECOM_gfrtPOW_II;
3474             break;
3475           }
3476         return ffecom_call_binop_ (ffecom_gfrt_tree_ (code),
3477                                    ffecom_gfrt_kindtype (code),
3478                                    (ffe_is_f2c_library ()
3479                                     && ffecom_gfrt_complex_[code]),
3480                                    tree_type, left, right,
3481                                    dest_tree, dest, dest_used,
3482                                    NULL_TREE, FALSE,
3483                                    ffebld_nonter_hook (expr));
3484       }
3485
3486     case FFEBLD_opNOT:
3487       switch (bt)
3488         {
3489         case FFEINFO_basictypeLOGICAL:
3490           item = ffecom_truth_value_invert (ffecom_expr (ffebld_left (expr)));
3491           return convert (tree_type, item);
3492
3493         case FFEINFO_basictypeINTEGER:
3494           return ffecom_1 (BIT_NOT_EXPR, tree_type,
3495                            ffecom_expr (ffebld_left (expr)));
3496
3497         default:
3498           assert ("NOT bad basictype" == NULL);
3499           /* Fall through. */
3500         case FFEINFO_basictypeANY:
3501           return error_mark_node;
3502         }
3503       break;
3504
3505     case FFEBLD_opFUNCREF:
3506       assert (ffeinfo_basictype (ffebld_info (expr))
3507               != FFEINFO_basictypeCHARACTER);
3508       /* Fall through.   */
3509     case FFEBLD_opSUBRREF:
3510       if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
3511           == FFEINFO_whereINTRINSIC)
3512         {                       /* Invocation of an intrinsic. */
3513           item = ffecom_expr_intrinsic_ (expr, dest_tree, dest,
3514                                          dest_used);
3515           return item;
3516         }
3517       s = ffebld_symter (ffebld_left (expr));
3518       dt = ffesymbol_hook (s).decl_tree;
3519       if (dt == NULL_TREE)
3520         {
3521           s = ffecom_sym_transform_ (s);
3522           dt = ffesymbol_hook (s).decl_tree;
3523         }
3524       if (dt == error_mark_node)
3525         return dt;
3526
3527       if (ffesymbol_hook (s).addr)
3528         item = dt;
3529       else
3530         item = ffecom_1_fn (dt);
3531
3532       if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
3533         args = ffecom_list_expr (ffebld_right (expr));
3534       else
3535         args = ffecom_list_ptr_to_expr (ffebld_right (expr));
3536
3537       if (args == error_mark_node)
3538         return error_mark_node;
3539
3540       item = ffecom_call_ (item, kt,
3541                            ffesymbol_is_f2c (s)
3542                            && (bt == FFEINFO_basictypeCOMPLEX)
3543                            && (ffesymbol_where (s)
3544                                != FFEINFO_whereCONSTANT),
3545                            tree_type,
3546                            args,
3547                            dest_tree, dest, dest_used,
3548                            error_mark_node, FALSE,
3549                            ffebld_nonter_hook (expr));
3550       TREE_SIDE_EFFECTS (item) = 1;
3551       return item;
3552
3553     case FFEBLD_opAND:
3554       switch (bt)
3555         {
3556         case FFEINFO_basictypeLOGICAL:
3557           item
3558             = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3559                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3560                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3561           return convert (tree_type, item);
3562
3563         case FFEINFO_basictypeINTEGER:
3564           return ffecom_2 (BIT_AND_EXPR, tree_type,
3565                            ffecom_expr (ffebld_left (expr)),
3566                            ffecom_expr (ffebld_right (expr)));
3567
3568         default:
3569           assert ("AND bad basictype" == NULL);
3570           /* Fall through. */
3571         case FFEINFO_basictypeANY:
3572           return error_mark_node;
3573         }
3574       break;
3575
3576     case FFEBLD_opOR:
3577       switch (bt)
3578         {
3579         case FFEINFO_basictypeLOGICAL:
3580           item
3581             = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
3582                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3583                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3584           return convert (tree_type, item);
3585
3586         case FFEINFO_basictypeINTEGER:
3587           return ffecom_2 (BIT_IOR_EXPR, tree_type,
3588                            ffecom_expr (ffebld_left (expr)),
3589                            ffecom_expr (ffebld_right (expr)));
3590
3591         default:
3592           assert ("OR bad basictype" == NULL);
3593           /* Fall through. */
3594         case FFEINFO_basictypeANY:
3595           return error_mark_node;
3596         }
3597       break;
3598
3599     case FFEBLD_opXOR:
3600     case FFEBLD_opNEQV:
3601       switch (bt)
3602         {
3603         case FFEINFO_basictypeLOGICAL:
3604           item
3605             = ffecom_2 (NE_EXPR, integer_type_node,
3606                         ffecom_expr (ffebld_left (expr)),
3607                         ffecom_expr (ffebld_right (expr)));
3608           return convert (tree_type, ffecom_truth_value (item));
3609
3610         case FFEINFO_basictypeINTEGER:
3611           return ffecom_2 (BIT_XOR_EXPR, tree_type,
3612                            ffecom_expr (ffebld_left (expr)),
3613                            ffecom_expr (ffebld_right (expr)));
3614
3615         default:
3616           assert ("XOR/NEQV bad basictype" == NULL);
3617           /* Fall through. */
3618         case FFEINFO_basictypeANY:
3619           return error_mark_node;
3620         }
3621       break;
3622
3623     case FFEBLD_opEQV:
3624       switch (bt)
3625         {
3626         case FFEINFO_basictypeLOGICAL:
3627           item
3628             = ffecom_2 (EQ_EXPR, integer_type_node,
3629                         ffecom_expr (ffebld_left (expr)),
3630                         ffecom_expr (ffebld_right (expr)));
3631           return convert (tree_type, ffecom_truth_value (item));
3632
3633         case FFEINFO_basictypeINTEGER:
3634           return
3635             ffecom_1 (BIT_NOT_EXPR, tree_type,
3636                       ffecom_2 (BIT_XOR_EXPR, tree_type,
3637                                 ffecom_expr (ffebld_left (expr)),
3638                                 ffecom_expr (ffebld_right (expr))));
3639
3640         default:
3641           assert ("EQV bad basictype" == NULL);
3642           /* Fall through. */
3643         case FFEINFO_basictypeANY:
3644           return error_mark_node;
3645         }
3646       break;
3647
3648     case FFEBLD_opCONVERT:
3649       if (ffebld_op (ffebld_left (expr)) == FFEBLD_opANY)
3650         return error_mark_node;
3651
3652       switch (bt)
3653         {
3654         case FFEINFO_basictypeLOGICAL:
3655         case FFEINFO_basictypeINTEGER:
3656         case FFEINFO_basictypeREAL:
3657           return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3658
3659         case FFEINFO_basictypeCOMPLEX:
3660           switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3661             {
3662             case FFEINFO_basictypeINTEGER:
3663             case FFEINFO_basictypeLOGICAL:
3664             case FFEINFO_basictypeREAL:
3665               item = ffecom_expr (ffebld_left (expr));
3666               if (item == error_mark_node)
3667                 return error_mark_node;
3668               /* convert() takes care of converting to the subtype first,
3669                  at least in gcc-2.7.2. */
3670               item = convert (tree_type, item);
3671               return item;
3672
3673             case FFEINFO_basictypeCOMPLEX:
3674               return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3675
3676             default:
3677               assert ("CONVERT COMPLEX bad basictype" == NULL);
3678               /* Fall through. */
3679             case FFEINFO_basictypeANY:
3680               return error_mark_node;
3681             }
3682           break;
3683
3684         default:
3685           assert ("CONVERT bad basictype" == NULL);
3686           /* Fall through. */
3687         case FFEINFO_basictypeANY:
3688           return error_mark_node;
3689         }
3690       break;
3691
3692     case FFEBLD_opLT:
3693       code = LT_EXPR;
3694       goto relational;          /* :::::::::::::::::::: */
3695
3696     case FFEBLD_opLE:
3697       code = LE_EXPR;
3698       goto relational;          /* :::::::::::::::::::: */
3699
3700     case FFEBLD_opEQ:
3701       code = EQ_EXPR;
3702       goto relational;          /* :::::::::::::::::::: */
3703
3704     case FFEBLD_opNE:
3705       code = NE_EXPR;
3706       goto relational;          /* :::::::::::::::::::: */
3707
3708     case FFEBLD_opGT:
3709       code = GT_EXPR;
3710       goto relational;          /* :::::::::::::::::::: */
3711
3712     case FFEBLD_opGE:
3713       code = GE_EXPR;
3714
3715     relational:         /* :::::::::::::::::::: */
3716       switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3717         {
3718         case FFEINFO_basictypeLOGICAL:
3719         case FFEINFO_basictypeINTEGER:
3720         case FFEINFO_basictypeREAL:
3721           item = ffecom_2 (code, integer_type_node,
3722                            ffecom_expr (ffebld_left (expr)),
3723                            ffecom_expr (ffebld_right (expr)));
3724           return convert (tree_type, item);
3725
3726         case FFEINFO_basictypeCOMPLEX:
3727           assert (code == EQ_EXPR || code == NE_EXPR);
3728           {
3729             tree real_type;
3730             tree arg1 = ffecom_expr (ffebld_left (expr));
3731             tree arg2 = ffecom_expr (ffebld_right (expr));
3732
3733             if (arg1 == error_mark_node || arg2 == error_mark_node)
3734               return error_mark_node;
3735
3736             arg1 = ffecom_save_tree (arg1);
3737             arg2 = ffecom_save_tree (arg2);
3738
3739             if (TREE_CODE (TREE_TYPE (arg1)) == COMPLEX_TYPE)
3740               {
3741                 real_type = TREE_TYPE (TREE_TYPE (arg1));
3742                 assert (real_type == TREE_TYPE (TREE_TYPE (arg2)));
3743               }
3744             else
3745               {
3746                 real_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg1)));
3747                 assert (real_type == TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg2))));
3748               }
3749
3750             item
3751               = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3752                           ffecom_2 (EQ_EXPR, integer_type_node,
3753                                   ffecom_1 (REALPART_EXPR, real_type, arg1),
3754                                  ffecom_1 (REALPART_EXPR, real_type, arg2)),
3755                           ffecom_2 (EQ_EXPR, integer_type_node,
3756                                   ffecom_1 (IMAGPART_EXPR, real_type, arg1),
3757                                     ffecom_1 (IMAGPART_EXPR, real_type,
3758                                               arg2)));
3759             if (code == EQ_EXPR)
3760               item = ffecom_truth_value (item);
3761             else
3762               item = ffecom_truth_value_invert (item);
3763             return convert (tree_type, item);
3764           }
3765
3766         case FFEINFO_basictypeCHARACTER:
3767           {
3768             ffebld left = ffebld_left (expr);
3769             ffebld right = ffebld_right (expr);
3770             tree left_tree;
3771             tree right_tree;
3772             tree left_length;
3773             tree right_length;
3774
3775             /* f2c run-time functions do the implicit blank-padding for us,
3776                so we don't usually have to implement blank-padding ourselves.
3777                (The exception is when we pass an argument to a separately
3778                compiled statement function -- if we know the arg is not the
3779                same length as the dummy, we must truncate or extend it.  If
3780                we "inline" statement functions, that necessity goes away as
3781                well.)
3782
3783                Strip off the CONVERT operators that blank-pad.  (Truncation by
3784                CONVERT shouldn't happen here, but it can happen in
3785                assignments.) */
3786
3787             while (ffebld_op (left) == FFEBLD_opCONVERT)
3788               left = ffebld_left (left);
3789             while (ffebld_op (right) == FFEBLD_opCONVERT)
3790               right = ffebld_left (right);
3791
3792             left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
3793             right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
3794
3795             if (left_tree == error_mark_node || left_length == error_mark_node
3796                 || right_tree == error_mark_node
3797                 || right_length == error_mark_node)
3798               return error_mark_node;
3799
3800             if ((ffebld_size_known (left) == 1)
3801                 && (ffebld_size_known (right) == 1))
3802               {
3803                 left_tree
3804                   = ffecom_1 (INDIRECT_REF,
3805                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3806                               left_tree);
3807                 right_tree
3808                   = ffecom_1 (INDIRECT_REF,
3809                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3810                               right_tree);
3811
3812                 item
3813                   = ffecom_2 (code, integer_type_node,
3814                               ffecom_2 (ARRAY_REF,
3815                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3816                                         left_tree,
3817                                         integer_one_node),
3818                               ffecom_2 (ARRAY_REF,
3819                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3820                                         right_tree,
3821                                         integer_one_node));
3822               }
3823             else
3824               {
3825                 item = build_tree_list (NULL_TREE, left_tree);
3826                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, right_tree);
3827                 TREE_CHAIN (TREE_CHAIN (item)) = build_tree_list (NULL_TREE,
3828                                                                left_length);
3829                 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
3830                   = build_tree_list (NULL_TREE, right_length);
3831                 item = ffecom_call_gfrt (FFECOM_gfrtCMP, item, NULL_TREE);
3832                 item = ffecom_2 (code, integer_type_node,
3833                                  item,
3834                                  convert (TREE_TYPE (item),
3835                                           integer_zero_node));
3836               }
3837             item = convert (tree_type, item);
3838           }
3839
3840           return item;
3841
3842         default:
3843           assert ("relational bad basictype" == NULL);
3844           /* Fall through. */
3845         case FFEINFO_basictypeANY:
3846           return error_mark_node;
3847         }
3848       break;
3849
3850     case FFEBLD_opPERCENT_LOC:
3851       item = ffecom_arg_ptr_to_expr (ffebld_left (expr), &list);
3852       return convert (tree_type, item);
3853
3854     case FFEBLD_opITEM:
3855     case FFEBLD_opSTAR:
3856     case FFEBLD_opBOUNDS:
3857     case FFEBLD_opREPEAT:
3858     case FFEBLD_opLABTER:
3859     case FFEBLD_opLABTOK:
3860     case FFEBLD_opIMPDO:
3861     case FFEBLD_opCONCATENATE:
3862     case FFEBLD_opSUBSTR:
3863     default:
3864       assert ("bad op" == NULL);
3865       /* Fall through. */
3866     case FFEBLD_opANY:
3867       return error_mark_node;
3868     }
3869
3870 #if 1
3871   assert ("didn't think anything got here anymore!!" == NULL);
3872 #else
3873   switch (ffebld_arity (expr))
3874     {
3875     case 2:
3876       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3877       TREE_OPERAND (item, 1) = ffecom_expr (ffebld_right (expr));
3878       if (TREE_OPERAND (item, 0) == error_mark_node
3879           || TREE_OPERAND (item, 1) == error_mark_node)
3880         return error_mark_node;
3881       break;
3882
3883     case 1:
3884       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3885       if (TREE_OPERAND (item, 0) == error_mark_node)
3886         return error_mark_node;
3887       break;
3888
3889     default:
3890       break;
3891     }
3892
3893   return fold (item);
3894 #endif
3895 }
3896
3897 #endif
3898 /* Returns the tree that does the intrinsic invocation.
3899
3900    Note: this function applies only to intrinsics returning
3901    CHARACTER*1 or non-CHARACTER results, and to intrinsic
3902    subroutines.  */
3903
3904 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3905 static tree
3906 ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
3907                         ffebld dest, bool *dest_used)
3908 {
3909   tree expr_tree;
3910   tree saved_expr1;             /* For those who need it. */
3911   tree saved_expr2;             /* For those who need it. */
3912   ffeinfoBasictype bt;
3913   ffeinfoKindtype kt;
3914   tree tree_type;
3915   tree arg1_type;
3916   tree real_type;               /* REAL type corresponding to COMPLEX. */
3917   tree tempvar;
3918   ffebld list = ffebld_right (expr);    /* List of (some) args. */
3919   ffebld arg1;                  /* For handy reference. */
3920   ffebld arg2;
3921   ffebld arg3;
3922   ffeintrinImp codegen_imp;
3923   ffecomGfrt gfrt;
3924
3925   assert (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER);
3926
3927   if (dest_used != NULL)
3928     *dest_used = FALSE;
3929
3930   bt = ffeinfo_basictype (ffebld_info (expr));
3931   kt = ffeinfo_kindtype (ffebld_info (expr));
3932   tree_type = ffecom_tree_type[bt][kt];
3933
3934   if (list != NULL)
3935     {
3936       arg1 = ffebld_head (list);
3937       if (arg1 != NULL && ffebld_op (arg1) == FFEBLD_opANY)
3938         return error_mark_node;
3939       if ((list = ffebld_trail (list)) != NULL)
3940         {
3941           arg2 = ffebld_head (list);
3942           if (arg2 != NULL && ffebld_op (arg2) == FFEBLD_opANY)
3943             return error_mark_node;
3944           if ((list = ffebld_trail (list)) != NULL)
3945             {
3946               arg3 = ffebld_head (list);
3947               if (arg3 != NULL && ffebld_op (arg3) == FFEBLD_opANY)
3948                 return error_mark_node;
3949             }
3950           else
3951             arg3 = NULL;
3952         }
3953       else
3954         arg2 = arg3 = NULL;
3955     }
3956   else
3957     arg1 = arg2 = arg3 = NULL;
3958
3959   /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
3960      args.  This is used by the MAX/MIN expansions. */
3961
3962   if (arg1 != NULL)
3963     arg1_type = ffecom_tree_type
3964       [ffeinfo_basictype (ffebld_info (arg1))]
3965       [ffeinfo_kindtype (ffebld_info (arg1))];
3966   else
3967     arg1_type = NULL_TREE;      /* Really not needed, but might catch bugs
3968                                    here. */
3969
3970   /* There are several ways for each of the cases in the following switch
3971      statements to exit (from simplest to use to most complicated):
3972
3973      break;  (when expr_tree == NULL)
3974
3975      A standard call is made to the specific intrinsic just as if it had been
3976      passed in as a dummy procedure and called as any old procedure.  This
3977      method can produce slower code but in some cases it's the easiest way for
3978      now.  However, if a (presumably faster) direct call is available,
3979      that is used, so this is the easiest way in many more cases now.
3980
3981      gfrt = FFECOM_gfrtWHATEVER;
3982      break;
3983
3984      gfrt contains the gfrt index of a library function to call, passing the
3985      argument(s) by value rather than by reference.  Used when a more
3986      careful choice of library function is needed than that provided
3987      by the vanilla `break;'.
3988
3989      return expr_tree;
3990
3991      The expr_tree has been completely set up and is ready to be returned
3992      as is.  No further actions are taken.  Use this when the tree is not
3993      in the simple form for one of the arity_n labels.   */
3994
3995   /* For info on how the switch statement cases were written, see the files
3996      enclosed in comments below the switch statement. */
3997
3998   codegen_imp = ffebld_symter_implementation (ffebld_left (expr));
3999   gfrt = ffeintrin_gfrt_direct (codegen_imp);
4000   if (gfrt == FFECOM_gfrt)
4001     gfrt = ffeintrin_gfrt_indirect (codegen_imp);
4002
4003   switch (codegen_imp)
4004     {
4005     case FFEINTRIN_impABS:
4006     case FFEINTRIN_impCABS:
4007     case FFEINTRIN_impCDABS:
4008     case FFEINTRIN_impDABS:
4009     case FFEINTRIN_impIABS:
4010       if (ffeinfo_basictype (ffebld_info (arg1))
4011           == FFEINFO_basictypeCOMPLEX)
4012         {
4013           if (kt == FFEINFO_kindtypeREAL1)
4014             gfrt = FFECOM_gfrtCABS;
4015           else if (kt == FFEINFO_kindtypeREAL2)
4016             gfrt = FFECOM_gfrtCDABS;
4017           break;
4018         }
4019       return ffecom_1 (ABS_EXPR, tree_type,
4020                        convert (tree_type, ffecom_expr (arg1)));
4021
4022     case FFEINTRIN_impACOS:
4023     case FFEINTRIN_impDACOS:
4024       break;
4025
4026     case FFEINTRIN_impAIMAG:
4027     case FFEINTRIN_impDIMAG:
4028     case FFEINTRIN_impIMAGPART:
4029       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
4030         arg1_type = TREE_TYPE (arg1_type);
4031       else
4032         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
4033
4034       return
4035         convert (tree_type,
4036                  ffecom_1 (IMAGPART_EXPR, arg1_type,
4037                            ffecom_expr (arg1)));
4038
4039     case FFEINTRIN_impAINT:
4040     case FFEINTRIN_impDINT:
4041 #if 0
4042       /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg.  */
4043       return ffecom_1 (FIX_TRUNC_EXPR, tree_type, ffecom_expr (arg1));
4044 #else /* in the meantime, must use floor to avoid range problems with ints */
4045       /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
4046       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4047       return
4048         convert (tree_type,
4049                  ffecom_3 (COND_EXPR, double_type_node,
4050                            ffecom_truth_value
4051                            (ffecom_2 (GE_EXPR, integer_type_node,
4052                                       saved_expr1,
4053                                       convert (arg1_type,
4054                                                ffecom_float_zero_))),
4055                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4056                                              build_tree_list (NULL_TREE,
4057                                                   convert (double_type_node,
4058                                                            saved_expr1)),
4059                                              NULL_TREE),
4060                            ffecom_1 (NEGATE_EXPR, double_type_node,
4061                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4062                                                  build_tree_list (NULL_TREE,
4063                                                   convert (double_type_node,
4064                                                       ffecom_1 (NEGATE_EXPR,
4065                                                                 arg1_type,
4066                                                                saved_expr1))),
4067                                                        NULL_TREE)
4068                                      ))
4069                  );
4070 #endif
4071
4072     case FFEINTRIN_impANINT:
4073     case FFEINTRIN_impDNINT:
4074 #if 0                           /* This way of doing it won't handle real
4075                                    numbers of large magnitudes. */
4076       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4077       expr_tree = convert (tree_type,
4078                            convert (integer_type_node,
4079                                     ffecom_3 (COND_EXPR, tree_type,
4080                                               ffecom_truth_value
4081                                               (ffecom_2 (GE_EXPR,
4082                                                          integer_type_node,
4083                                                          saved_expr1,
4084                                                        ffecom_float_zero_)),
4085                                               ffecom_2 (PLUS_EXPR,
4086                                                         tree_type,
4087                                                         saved_expr1,
4088                                                         ffecom_float_half_),
4089                                               ffecom_2 (MINUS_EXPR,
4090                                                         tree_type,
4091                                                         saved_expr1,
4092                                                      ffecom_float_half_))));
4093       return expr_tree;
4094 #else /* So we instead call floor. */
4095       /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
4096       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4097       return
4098         convert (tree_type,
4099                  ffecom_3 (COND_EXPR, double_type_node,
4100                            ffecom_truth_value
4101                            (ffecom_2 (GE_EXPR, integer_type_node,
4102                                       saved_expr1,
4103                                       convert (arg1_type,
4104                                                ffecom_float_zero_))),
4105                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4106                                              build_tree_list (NULL_TREE,
4107                                                   convert (double_type_node,
4108                                                            ffecom_2 (PLUS_EXPR,
4109                                                                      arg1_type,
4110                                                                      saved_expr1,
4111                                                                      convert (arg1_type,
4112                                                                               ffecom_float_half_)))),
4113                                              NULL_TREE),
4114                            ffecom_1 (NEGATE_EXPR, double_type_node,
4115                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4116                                                        build_tree_list (NULL_TREE,
4117                                                                         convert (double_type_node,
4118                                                                                  ffecom_2 (MINUS_EXPR,
4119                                                                                            arg1_type,
4120                                                                                            convert (arg1_type,
4121                                                                                                     ffecom_float_half_),
4122                                                                                            saved_expr1))),
4123                                                        NULL_TREE))
4124                            )
4125                  );
4126 #endif
4127
4128     case FFEINTRIN_impASIN:
4129     case FFEINTRIN_impDASIN:
4130     case FFEINTRIN_impATAN:
4131     case FFEINTRIN_impDATAN:
4132     case FFEINTRIN_impATAN2:
4133     case FFEINTRIN_impDATAN2:
4134       break;
4135
4136     case FFEINTRIN_impCHAR:
4137     case FFEINTRIN_impACHAR:
4138 #ifdef HOHO
4139       tempvar = ffecom_make_tempvar (char_type_node, 1, -1);
4140 #else
4141       tempvar = ffebld_nonter_hook (expr);
4142       assert (tempvar);
4143 #endif
4144       {
4145         tree tmv = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar)));
4146
4147         expr_tree = ffecom_modify (tmv,
4148                                    ffecom_2 (ARRAY_REF, tmv, tempvar,
4149                                              integer_one_node),
4150                                    convert (tmv, ffecom_expr (arg1)));
4151       }
4152       expr_tree = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar),
4153                             expr_tree,
4154                             tempvar);
4155       expr_tree = ffecom_1 (ADDR_EXPR,
4156                             build_pointer_type (TREE_TYPE (expr_tree)),
4157                             expr_tree);
4158       return expr_tree;
4159
4160     case FFEINTRIN_impCMPLX:
4161     case FFEINTRIN_impDCMPLX:
4162       if (arg2 == NULL)
4163         return
4164           convert (tree_type, ffecom_expr (arg1));
4165
4166       real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4167       return
4168         ffecom_2 (COMPLEX_EXPR, tree_type,
4169                   convert (real_type, ffecom_expr (arg1)),
4170                   convert (real_type,
4171                            ffecom_expr (arg2)));
4172
4173     case FFEINTRIN_impCOMPLEX:
4174       return
4175         ffecom_2 (COMPLEX_EXPR, tree_type,
4176                   ffecom_expr (arg1),
4177                   ffecom_expr (arg2));
4178
4179     case FFEINTRIN_impCONJG:
4180     case FFEINTRIN_impDCONJG:
4181       {
4182         tree arg1_tree;
4183
4184         real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4185         arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4186         return
4187           ffecom_2 (COMPLEX_EXPR, tree_type,
4188                     ffecom_1 (REALPART_EXPR, real_type, arg1_tree),
4189                     ffecom_1 (NEGATE_EXPR, real_type,
4190                               ffecom_1 (IMAGPART_EXPR, real_type, arg1_tree)));
4191       }
4192
4193     case FFEINTRIN_impCOS:
4194     case FFEINTRIN_impCCOS:
4195     case FFEINTRIN_impCDCOS:
4196     case FFEINTRIN_impDCOS:
4197       if (bt == FFEINFO_basictypeCOMPLEX)
4198         {
4199           if (kt == FFEINFO_kindtypeREAL1)
4200             gfrt = FFECOM_gfrtCCOS;     /* Overlapping result okay. */
4201           else if (kt == FFEINFO_kindtypeREAL2)
4202             gfrt = FFECOM_gfrtCDCOS;    /* Overlapping result okay. */
4203         }
4204       break;
4205
4206     case FFEINTRIN_impCOSH:
4207     case FFEINTRIN_impDCOSH:
4208       break;
4209
4210     case FFEINTRIN_impDBLE:
4211     case FFEINTRIN_impDFLOAT:
4212     case FFEINTRIN_impDREAL:
4213     case FFEINTRIN_impFLOAT:
4214     case FFEINTRIN_impIDINT:
4215     case FFEINTRIN_impIFIX:
4216     case FFEINTRIN_impINT2:
4217     case FFEINTRIN_impINT8:
4218     case FFEINTRIN_impINT:
4219     case FFEINTRIN_impLONG:
4220     case FFEINTRIN_impREAL:
4221     case FFEINTRIN_impSHORT:
4222     case FFEINTRIN_impSNGL:
4223       return convert (tree_type, ffecom_expr (arg1));
4224
4225     case FFEINTRIN_impDIM:
4226     case FFEINTRIN_impDDIM:
4227     case FFEINTRIN_impIDIM:
4228       saved_expr1 = ffecom_save_tree (convert (tree_type,
4229                                                ffecom_expr (arg1)));
4230       saved_expr2 = ffecom_save_tree (convert (tree_type,
4231                                                ffecom_expr (arg2)));
4232       return
4233         ffecom_3 (COND_EXPR, tree_type,
4234                   ffecom_truth_value
4235                   (ffecom_2 (GT_EXPR, integer_type_node,
4236                              saved_expr1,
4237                              saved_expr2)),
4238                   ffecom_2 (MINUS_EXPR, tree_type,
4239                             saved_expr1,
4240                             saved_expr2),
4241                   convert (tree_type, ffecom_float_zero_));
4242
4243     case FFEINTRIN_impDPROD:
4244       return
4245         ffecom_2 (MULT_EXPR, tree_type,
4246                   convert (tree_type, ffecom_expr (arg1)),
4247                   convert (tree_type, ffecom_expr (arg2)));
4248
4249     case FFEINTRIN_impEXP:
4250     case FFEINTRIN_impCDEXP:
4251     case FFEINTRIN_impCEXP:
4252     case FFEINTRIN_impDEXP:
4253       if (bt == FFEINFO_basictypeCOMPLEX)
4254         {
4255           if (kt == FFEINFO_kindtypeREAL1)
4256             gfrt = FFECOM_gfrtCEXP;     /* Overlapping result okay. */
4257           else if (kt == FFEINFO_kindtypeREAL2)
4258             gfrt = FFECOM_gfrtCDEXP;    /* Overlapping result okay. */
4259         }
4260       break;
4261
4262     case FFEINTRIN_impICHAR:
4263     case FFEINTRIN_impIACHAR:
4264 #if 0                           /* The simple approach. */
4265       ffecom_char_args_ (&expr_tree, &saved_expr1 /* Ignored */ , arg1);
4266       expr_tree
4267         = ffecom_1 (INDIRECT_REF,
4268                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4269                     expr_tree);
4270       expr_tree
4271         = ffecom_2 (ARRAY_REF,
4272                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4273                     expr_tree,
4274                     integer_one_node);
4275       return convert (tree_type, expr_tree);
4276 #else /* The more interesting (and more optimal) approach. */
4277       expr_tree = ffecom_intrinsic_ichar_ (tree_type, arg1, &saved_expr1);
4278       expr_tree = ffecom_3 (COND_EXPR, tree_type,
4279                             saved_expr1,
4280                             expr_tree,
4281                             convert (tree_type, integer_zero_node));
4282       return expr_tree;
4283 #endif
4284
4285     case FFEINTRIN_impINDEX:
4286       break;
4287
4288     case FFEINTRIN_impLEN:
4289 #if 0
4290       break;                                    /* The simple approach. */
4291 #else
4292       return ffecom_intrinsic_len_ (arg1);      /* The more optimal approach. */
4293 #endif
4294
4295     case FFEINTRIN_impLGE:
4296     case FFEINTRIN_impLGT:
4297     case FFEINTRIN_impLLE:
4298     case FFEINTRIN_impLLT:
4299       break;
4300
4301     case FFEINTRIN_impLOG:
4302     case FFEINTRIN_impALOG:
4303     case FFEINTRIN_impCDLOG:
4304     case FFEINTRIN_impCLOG:
4305     case FFEINTRIN_impDLOG:
4306       if (bt == FFEINFO_basictypeCOMPLEX)
4307         {
4308           if (kt == FFEINFO_kindtypeREAL1)
4309             gfrt = FFECOM_gfrtCLOG;     /* Overlapping result okay. */
4310           else if (kt == FFEINFO_kindtypeREAL2)
4311             gfrt = FFECOM_gfrtCDLOG;    /* Overlapping result okay. */
4312         }
4313       break;
4314
4315     case FFEINTRIN_impLOG10:
4316     case FFEINTRIN_impALOG10:
4317     case FFEINTRIN_impDLOG10:
4318       if (gfrt != FFECOM_gfrt)
4319         break;  /* Already picked one, stick with it. */
4320
4321       if (kt == FFEINFO_kindtypeREAL1)
4322         gfrt = FFECOM_gfrtALOG10;
4323       else if (kt == FFEINFO_kindtypeREAL2)
4324         gfrt = FFECOM_gfrtDLOG10;
4325       break;
4326
4327     case FFEINTRIN_impMAX:
4328     case FFEINTRIN_impAMAX0:
4329     case FFEINTRIN_impAMAX1:
4330     case FFEINTRIN_impDMAX1:
4331     case FFEINTRIN_impMAX0:
4332     case FFEINTRIN_impMAX1:
4333       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4334         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4335       else
4336         arg1_type = tree_type;
4337       expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4338                             convert (arg1_type, ffecom_expr (arg1)),
4339                             convert (arg1_type, ffecom_expr (arg2)));
4340       for (; list != NULL; list = ffebld_trail (list))
4341         {
4342           if ((ffebld_head (list) == NULL)
4343               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4344             continue;
4345           expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4346                                 expr_tree,
4347                                 convert (arg1_type,
4348                                          ffecom_expr (ffebld_head (list))));
4349         }
4350       return convert (tree_type, expr_tree);
4351
4352     case FFEINTRIN_impMIN:
4353     case FFEINTRIN_impAMIN0:
4354     case FFEINTRIN_impAMIN1:
4355     case FFEINTRIN_impDMIN1:
4356     case FFEINTRIN_impMIN0:
4357     case FFEINTRIN_impMIN1:
4358       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4359         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4360       else
4361         arg1_type = tree_type;
4362       expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4363                             convert (arg1_type, ffecom_expr (arg1)),
4364                             convert (arg1_type, ffecom_expr (arg2)));
4365       for (; list != NULL; list = ffebld_trail (list))
4366         {
4367           if ((ffebld_head (list) == NULL)
4368               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4369             continue;
4370           expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4371                                 expr_tree,
4372                                 convert (arg1_type,
4373                                          ffecom_expr (ffebld_head (list))));
4374         }
4375       return convert (tree_type, expr_tree);
4376
4377     case FFEINTRIN_impMOD:
4378     case FFEINTRIN_impAMOD:
4379     case FFEINTRIN_impDMOD:
4380       if (bt != FFEINFO_basictypeREAL)
4381         return ffecom_2 (TRUNC_MOD_EXPR, tree_type,
4382                          convert (tree_type, ffecom_expr (arg1)),
4383                          convert (tree_type, ffecom_expr (arg2)));
4384
4385       if (kt == FFEINFO_kindtypeREAL1)
4386         gfrt = FFECOM_gfrtAMOD;
4387       else if (kt == FFEINFO_kindtypeREAL2)
4388         gfrt = FFECOM_gfrtDMOD;
4389       break;
4390
4391     case FFEINTRIN_impNINT:
4392     case FFEINTRIN_impIDNINT:
4393 #if 0
4394       /* ~~Ideally FIX_ROUND_EXPR would be implemented, but it ain't yet.  */
4395       return ffecom_1 (FIX_ROUND_EXPR, tree_type, ffecom_expr (arg1));
4396 #else
4397       /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
4398       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4399       return
4400         convert (ffecom_integer_type_node,
4401                  ffecom_3 (COND_EXPR, arg1_type,
4402                            ffecom_truth_value
4403                            (ffecom_2 (GE_EXPR, integer_type_node,
4404                                       saved_expr1,
4405                                       convert (arg1_type,
4406                                                ffecom_float_zero_))),
4407                            ffecom_2 (PLUS_EXPR, arg1_type,
4408                                      saved_expr1,
4409                                      convert (arg1_type,
4410                                               ffecom_float_half_)),
4411                            ffecom_2 (MINUS_EXPR, arg1_type,
4412                                      saved_expr1,
4413                                      convert (arg1_type,
4414                                               ffecom_float_half_))));
4415 #endif
4416
4417     case FFEINTRIN_impSIGN:
4418     case FFEINTRIN_impDSIGN:
4419     case FFEINTRIN_impISIGN:
4420       {
4421         tree arg2_tree = ffecom_expr (arg2);
4422
4423         saved_expr1
4424           = ffecom_save_tree
4425           (ffecom_1 (ABS_EXPR, tree_type,
4426                      convert (tree_type,
4427                               ffecom_expr (arg1))));
4428         expr_tree
4429           = ffecom_3 (COND_EXPR, tree_type,
4430                       ffecom_truth_value
4431                       (ffecom_2 (GE_EXPR, integer_type_node,
4432                                  arg2_tree,
4433                                  convert (TREE_TYPE (arg2_tree),
4434                                           integer_zero_node))),
4435                       saved_expr1,
4436                       ffecom_1 (NEGATE_EXPR, tree_type, saved_expr1));
4437         /* Make sure SAVE_EXPRs get referenced early enough. */
4438         expr_tree
4439           = ffecom_2 (COMPOUND_EXPR, tree_type,
4440                       convert (void_type_node, saved_expr1),
4441                       expr_tree);
4442       }
4443       return expr_tree;
4444
4445     case FFEINTRIN_impSIN:
4446     case FFEINTRIN_impCDSIN:
4447     case FFEINTRIN_impCSIN:
4448     case FFEINTRIN_impDSIN:
4449       if (bt == FFEINFO_basictypeCOMPLEX)
4450         {
4451           if (kt == FFEINFO_kindtypeREAL1)
4452             gfrt = FFECOM_gfrtCSIN;     /* Overlapping result okay. */
4453           else if (kt == FFEINFO_kindtypeREAL2)
4454             gfrt = FFECOM_gfrtCDSIN;    /* Overlapping result okay. */
4455         }
4456       break;
4457
4458     case FFEINTRIN_impSINH:
4459     case FFEINTRIN_impDSINH:
4460       break;
4461
4462     case FFEINTRIN_impSQRT:
4463     case FFEINTRIN_impCDSQRT:
4464     case FFEINTRIN_impCSQRT:
4465     case FFEINTRIN_impDSQRT:
4466       if (bt == FFEINFO_basictypeCOMPLEX)
4467         {
4468           if (kt == FFEINFO_kindtypeREAL1)
4469             gfrt = FFECOM_gfrtCSQRT;    /* Overlapping result okay. */
4470           else if (kt == FFEINFO_kindtypeREAL2)
4471             gfrt = FFECOM_gfrtCDSQRT;   /* Overlapping result okay. */
4472         }
4473       break;
4474
4475     case FFEINTRIN_impTAN:
4476     case FFEINTRIN_impDTAN:
4477     case FFEINTRIN_impTANH:
4478     case FFEINTRIN_impDTANH:
4479       break;
4480
4481     case FFEINTRIN_impREALPART:
4482       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
4483         arg1_type = TREE_TYPE (arg1_type);
4484       else
4485         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
4486
4487       return
4488         convert (tree_type,
4489                  ffecom_1 (REALPART_EXPR, arg1_type,
4490                            ffecom_expr (arg1)));
4491
4492     case FFEINTRIN_impIAND:
4493     case FFEINTRIN_impAND:
4494       return ffecom_2 (BIT_AND_EXPR, tree_type,
4495                        convert (tree_type,
4496                                 ffecom_expr (arg1)),
4497                        convert (tree_type,
4498                                 ffecom_expr (arg2)));
4499
4500     case FFEINTRIN_impIOR:
4501     case FFEINTRIN_impOR:
4502       return ffecom_2 (BIT_IOR_EXPR, tree_type,
4503                        convert (tree_type,
4504                                 ffecom_expr (arg1)),
4505                        convert (tree_type,
4506                                 ffecom_expr (arg2)));
4507
4508     case FFEINTRIN_impIEOR:
4509     case FFEINTRIN_impXOR:
4510       return ffecom_2 (BIT_XOR_EXPR, tree_type,
4511                        convert (tree_type,
4512                                 ffecom_expr (arg1)),
4513                        convert (tree_type,
4514                                 ffecom_expr (arg2)));
4515
4516     case FFEINTRIN_impLSHIFT:
4517       return ffecom_2 (LSHIFT_EXPR, tree_type,
4518                        ffecom_expr (arg1),
4519                        convert (integer_type_node,
4520                                 ffecom_expr (arg2)));
4521
4522     case FFEINTRIN_impRSHIFT:
4523       return ffecom_2 (RSHIFT_EXPR, tree_type,
4524                        ffecom_expr (arg1),
4525                        convert (integer_type_node,
4526                                 ffecom_expr (arg2)));
4527
4528     case FFEINTRIN_impNOT:
4529       return ffecom_1 (BIT_NOT_EXPR, tree_type, ffecom_expr (arg1));
4530
4531     case FFEINTRIN_impBIT_SIZE:
4532       return convert (tree_type, TYPE_SIZE (arg1_type));
4533
4534     case FFEINTRIN_impBTEST:
4535       {
4536         ffetargetLogical1 true;
4537         ffetargetLogical1 false;
4538         tree true_tree;
4539         tree false_tree;
4540
4541         ffetarget_logical1 (&true, TRUE);
4542         ffetarget_logical1 (&false, FALSE);
4543         if (true == 1)
4544           true_tree = convert (tree_type, integer_one_node);
4545         else
4546           true_tree = convert (tree_type, build_int_2 (true, 0));
4547         if (false == 0)
4548           false_tree = convert (tree_type, integer_zero_node);
4549         else
4550           false_tree = convert (tree_type, build_int_2 (false, 0));
4551
4552         return
4553           ffecom_3 (COND_EXPR, tree_type,
4554                     ffecom_truth_value
4555                     (ffecom_2 (EQ_EXPR, integer_type_node,
4556                                ffecom_2 (BIT_AND_EXPR, arg1_type,
4557                                          ffecom_expr (arg1),
4558                                          ffecom_2 (LSHIFT_EXPR, arg1_type,
4559                                                    convert (arg1_type,
4560                                                           integer_one_node),
4561                                                    convert (integer_type_node,
4562                                                             ffecom_expr (arg2)))),
4563                                convert (arg1_type,
4564                                         integer_zero_node))),
4565                     false_tree,
4566                     true_tree);
4567       }
4568
4569     case FFEINTRIN_impIBCLR:
4570       return
4571         ffecom_2 (BIT_AND_EXPR, tree_type,
4572                   ffecom_expr (arg1),
4573                   ffecom_1 (BIT_NOT_EXPR, tree_type,
4574                             ffecom_2 (LSHIFT_EXPR, tree_type,
4575                                       convert (tree_type,
4576                                                integer_one_node),
4577                                       convert (integer_type_node,
4578                                                ffecom_expr (arg2)))));
4579
4580     case FFEINTRIN_impIBITS:
4581       {
4582         tree arg3_tree = ffecom_save_tree (convert (integer_type_node,
4583                                                     ffecom_expr (arg3)));
4584         tree uns_type
4585         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4586
4587         expr_tree
4588           = ffecom_2 (BIT_AND_EXPR, tree_type,
4589                       ffecom_2 (RSHIFT_EXPR, tree_type,
4590                                 ffecom_expr (arg1),
4591                                 convert (integer_type_node,
4592                                          ffecom_expr (arg2))),
4593                       convert (tree_type,
4594                                ffecom_2 (RSHIFT_EXPR, uns_type,
4595                                          ffecom_1 (BIT_NOT_EXPR,
4596                                                    uns_type,
4597                                                    convert (uns_type,
4598                                                         integer_zero_node)),
4599                                          ffecom_2 (MINUS_EXPR,
4600                                                    integer_type_node,
4601                                                    TYPE_SIZE (uns_type),
4602                                                    arg3_tree))));
4603 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4604         expr_tree
4605           = ffecom_3 (COND_EXPR, tree_type,
4606                       ffecom_truth_value
4607                       (ffecom_2 (NE_EXPR, integer_type_node,
4608                                  arg3_tree,
4609                                  integer_zero_node)),
4610                       expr_tree,
4611                       convert (tree_type, integer_zero_node));
4612 #endif
4613       }
4614       return expr_tree;
4615
4616     case FFEINTRIN_impIBSET:
4617       return
4618         ffecom_2 (BIT_IOR_EXPR, tree_type,
4619                   ffecom_expr (arg1),
4620                   ffecom_2 (LSHIFT_EXPR, tree_type,
4621                             convert (tree_type, integer_one_node),
4622                             convert (integer_type_node,
4623                                      ffecom_expr (arg2))));
4624
4625     case FFEINTRIN_impISHFT:
4626       {
4627         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4628         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4629                                                     ffecom_expr (arg2)));
4630         tree uns_type
4631         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4632
4633         expr_tree
4634           = ffecom_3 (COND_EXPR, tree_type,
4635                       ffecom_truth_value
4636                       (ffecom_2 (GE_EXPR, integer_type_node,
4637                                  arg2_tree,
4638                                  integer_zero_node)),
4639                       ffecom_2 (LSHIFT_EXPR, tree_type,
4640                                 arg1_tree,
4641                                 arg2_tree),
4642                       convert (tree_type,
4643                                ffecom_2 (RSHIFT_EXPR, uns_type,
4644                                          convert (uns_type, arg1_tree),
4645                                          ffecom_1 (NEGATE_EXPR,
4646                                                    integer_type_node,
4647                                                    arg2_tree))));
4648 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4649         expr_tree
4650           = ffecom_3 (COND_EXPR, tree_type,
4651                       ffecom_truth_value
4652                       (ffecom_2 (NE_EXPR, integer_type_node,
4653                                  arg2_tree,
4654                                  TYPE_SIZE (uns_type))),
4655                       expr_tree,
4656                       convert (tree_type, integer_zero_node));
4657 #endif
4658         /* Make sure SAVE_EXPRs get referenced early enough. */
4659         expr_tree
4660           = ffecom_2 (COMPOUND_EXPR, tree_type,
4661                       convert (void_type_node, arg1_tree),
4662                       ffecom_2 (COMPOUND_EXPR, tree_type,
4663                                 convert (void_type_node, arg2_tree),
4664                                 expr_tree));
4665       }
4666       return expr_tree;
4667
4668     case FFEINTRIN_impISHFTC:
4669       {
4670         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4671         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4672                                                     ffecom_expr (arg2)));
4673         tree arg3_tree = (arg3 == NULL) ? TYPE_SIZE (tree_type)
4674         : ffecom_save_tree (convert (integer_type_node, ffecom_expr (arg3)));
4675         tree shift_neg;
4676         tree shift_pos;
4677         tree mask_arg1;
4678         tree masked_arg1;
4679         tree uns_type
4680         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4681
4682         mask_arg1
4683           = ffecom_2 (LSHIFT_EXPR, tree_type,
4684                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4685                                 convert (tree_type, integer_zero_node)),
4686                       arg3_tree);
4687 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4688         mask_arg1
4689           = ffecom_3 (COND_EXPR, tree_type,
4690                       ffecom_truth_value
4691                       (ffecom_2 (NE_EXPR, integer_type_node,
4692                                  arg3_tree,
4693                                  TYPE_SIZE (uns_type))),
4694                       mask_arg1,
4695                       convert (tree_type, integer_zero_node));
4696 #endif
4697         mask_arg1 = ffecom_save_tree (mask_arg1);
4698         masked_arg1
4699           = ffecom_2 (BIT_AND_EXPR, tree_type,
4700                       arg1_tree,
4701                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4702                                 mask_arg1));
4703         masked_arg1 = ffecom_save_tree (masked_arg1);
4704         shift_neg
4705           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4706                       convert (tree_type,
4707                                ffecom_2 (RSHIFT_EXPR, uns_type,
4708                                          convert (uns_type, masked_arg1),
4709                                          ffecom_1 (NEGATE_EXPR,
4710                                                    integer_type_node,
4711                                                    arg2_tree))),
4712                       ffecom_2 (LSHIFT_EXPR, tree_type,
4713                                 arg1_tree,
4714                                 ffecom_2 (PLUS_EXPR, integer_type_node,
4715                                           arg2_tree,
4716                                           arg3_tree)));
4717         shift_pos
4718           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4719                       ffecom_2 (LSHIFT_EXPR, tree_type,
4720                                 arg1_tree,
4721                                 arg2_tree),
4722                       convert (tree_type,
4723                                ffecom_2 (RSHIFT_EXPR, uns_type,
4724                                          convert (uns_type, masked_arg1),
4725                                          ffecom_2 (MINUS_EXPR,
4726                                                    integer_type_node,
4727                                                    arg3_tree,
4728                                                    arg2_tree))));
4729         expr_tree
4730           = ffecom_3 (COND_EXPR, tree_type,
4731                       ffecom_truth_value
4732                       (ffecom_2 (LT_EXPR, integer_type_node,
4733                                  arg2_tree,
4734                                  integer_zero_node)),
4735                       shift_neg,
4736                       shift_pos);
4737         expr_tree
4738           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4739                       ffecom_2 (BIT_AND_EXPR, tree_type,
4740                                 mask_arg1,
4741                                 arg1_tree),
4742                       ffecom_2 (BIT_AND_EXPR, tree_type,
4743                                 ffecom_1 (BIT_NOT_EXPR, tree_type,
4744                                           mask_arg1),
4745                                 expr_tree));
4746         expr_tree
4747           = ffecom_3 (COND_EXPR, tree_type,
4748                       ffecom_truth_value
4749                       (ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
4750                                  ffecom_2 (EQ_EXPR, integer_type_node,
4751                                            ffecom_1 (ABS_EXPR,
4752                                                      integer_type_node,
4753                                                      arg2_tree),
4754                                            arg3_tree),
4755                                  ffecom_2 (EQ_EXPR, integer_type_node,
4756                                            arg2_tree,
4757                                            integer_zero_node))),
4758                       arg1_tree,
4759                       expr_tree);
4760         /* Make sure SAVE_EXPRs get referenced early enough. */
4761         expr_tree
4762           = ffecom_2 (COMPOUND_EXPR, tree_type,
4763                       convert (void_type_node, arg1_tree),
4764                       ffecom_2 (COMPOUND_EXPR, tree_type,
4765                                 convert (void_type_node, arg2_tree),
4766                                 ffecom_2 (COMPOUND_EXPR, tree_type,
4767                                           convert (void_type_node,
4768                                                    mask_arg1),
4769                                           ffecom_2 (COMPOUND_EXPR, tree_type,
4770                                                     convert (void_type_node,
4771                                                              masked_arg1),
4772                                                     expr_tree))));
4773         expr_tree
4774           = ffecom_2 (COMPOUND_EXPR, tree_type,
4775                       convert (void_type_node,
4776                                arg3_tree),
4777                       expr_tree);
4778       }
4779       return expr_tree;
4780
4781     case FFEINTRIN_impLOC:
4782       {
4783         tree arg1_tree = ffecom_expr (arg1);
4784
4785         expr_tree
4786           = convert (tree_type,
4787                      ffecom_1 (ADDR_EXPR,
4788                                build_pointer_type (TREE_TYPE (arg1_tree)),
4789                                arg1_tree));
4790       }
4791       return expr_tree;
4792
4793     case FFEINTRIN_impMVBITS:
4794       {
4795         tree arg1_tree;
4796         tree arg2_tree;
4797         tree arg3_tree;
4798         ffebld arg4 = ffebld_head (ffebld_trail (list));
4799         tree arg4_tree;
4800         tree arg4_type;
4801         ffebld arg5 = ffebld_head (ffebld_trail (ffebld_trail (list)));
4802         tree arg5_tree;
4803         tree prep_arg1;
4804         tree prep_arg4;
4805         tree arg5_plus_arg3;
4806
4807         arg2_tree = convert (integer_type_node,
4808                              ffecom_expr (arg2));
4809         arg3_tree = ffecom_save_tree (convert (integer_type_node,
4810                                                ffecom_expr (arg3)));
4811         arg4_tree = ffecom_expr_rw (NULL_TREE, arg4);
4812         arg4_type = TREE_TYPE (arg4_tree);
4813
4814         arg1_tree = ffecom_save_tree (convert (arg4_type,
4815                                                ffecom_expr (arg1)));
4816
4817         arg5_tree = ffecom_save_tree (convert (integer_type_node,
4818                                                ffecom_expr (arg5)));
4819
4820         prep_arg1
4821           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4822                       ffecom_2 (BIT_AND_EXPR, arg4_type,
4823                                 ffecom_2 (RSHIFT_EXPR, arg4_type,
4824                                           arg1_tree,
4825                                           arg2_tree),
4826                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4827                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4828                                                     ffecom_1 (BIT_NOT_EXPR,
4829                                                               arg4_type,
4830                                                               convert
4831                                                               (arg4_type,
4832                                                         integer_zero_node)),
4833                                                     arg3_tree))),
4834                       arg5_tree);
4835         arg5_plus_arg3
4836           = ffecom_save_tree (ffecom_2 (PLUS_EXPR, arg4_type,
4837                                         arg5_tree,
4838                                         arg3_tree));
4839         prep_arg4
4840           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4841                       ffecom_1 (BIT_NOT_EXPR, arg4_type,
4842                                 convert (arg4_type,
4843                                          integer_zero_node)),
4844                       arg5_plus_arg3);
4845 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4846         prep_arg4
4847           = ffecom_3 (COND_EXPR, arg4_type,
4848                       ffecom_truth_value
4849                       (ffecom_2 (NE_EXPR, integer_type_node,
4850                                  arg5_plus_arg3,
4851                                  convert (TREE_TYPE (arg5_plus_arg3),
4852                                           TYPE_SIZE (arg4_type)))),
4853                       prep_arg4,
4854                       convert (arg4_type, integer_zero_node));
4855 #endif
4856         prep_arg4
4857           = ffecom_2 (BIT_AND_EXPR, arg4_type,
4858                       arg4_tree,
4859                       ffecom_2 (BIT_IOR_EXPR, arg4_type,
4860                                 prep_arg4,
4861                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4862                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4863                                                     ffecom_1 (BIT_NOT_EXPR,
4864                                                               arg4_type,
4865                                                               convert
4866                                                               (arg4_type,
4867                                                         integer_zero_node)),
4868                                                     arg5_tree))));
4869         prep_arg1
4870           = ffecom_2 (BIT_IOR_EXPR, arg4_type,
4871                       prep_arg1,
4872                       prep_arg4);
4873 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4874         prep_arg1
4875           = ffecom_3 (COND_EXPR, arg4_type,
4876                       ffecom_truth_value
4877                       (ffecom_2 (NE_EXPR, integer_type_node,
4878                                  arg3_tree,
4879                                  convert (TREE_TYPE (arg3_tree),
4880                                           integer_zero_node))),
4881                       prep_arg1,
4882                       arg4_tree);
4883         prep_arg1
4884           = ffecom_3 (COND_EXPR, arg4_type,
4885                       ffecom_truth_value
4886                       (ffecom_2 (NE_EXPR, integer_type_node,
4887                                  arg3_tree,
4888                                  convert (TREE_TYPE (arg3_tree),
4889                                           TYPE_SIZE (arg4_type)))),
4890                       prep_arg1,
4891                       arg1_tree);
4892 #endif
4893         expr_tree
4894           = ffecom_2s (MODIFY_EXPR, void_type_node,
4895                        arg4_tree,
4896                        prep_arg1);
4897         /* Make sure SAVE_EXPRs get referenced early enough. */
4898         expr_tree
4899           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4900                       arg1_tree,
4901                       ffecom_2 (COMPOUND_EXPR, void_type_node,
4902                                 arg3_tree,
4903                                 ffecom_2 (COMPOUND_EXPR, void_type_node,
4904                                           arg5_tree,
4905                                           ffecom_2 (COMPOUND_EXPR, void_type_node,
4906                                                     arg5_plus_arg3,
4907                                                     expr_tree))));
4908         expr_tree
4909           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4910                       arg4_tree,
4911                       expr_tree);
4912
4913       }
4914       return expr_tree;
4915
4916     case FFEINTRIN_impDERF:
4917     case FFEINTRIN_impERF:
4918     case FFEINTRIN_impDERFC:
4919     case FFEINTRIN_impERFC:
4920       break;
4921
4922     case FFEINTRIN_impIARGC:
4923       /* extern int xargc; i__1 = xargc - 1; */
4924       expr_tree = ffecom_2 (MINUS_EXPR, TREE_TYPE (ffecom_tree_xargc_),
4925                             ffecom_tree_xargc_,
4926                             convert (TREE_TYPE (ffecom_tree_xargc_),
4927                                      integer_one_node));
4928       return expr_tree;
4929
4930     case FFEINTRIN_impSIGNAL_func:
4931     case FFEINTRIN_impSIGNAL_subr:
4932       {
4933         tree arg1_tree;
4934         tree arg2_tree;
4935         tree arg3_tree;
4936
4937         arg1_tree = convert (ffecom_f2c_integer_type_node,
4938                              ffecom_expr (arg1));
4939         arg1_tree = ffecom_1 (ADDR_EXPR,
4940                               build_pointer_type (TREE_TYPE (arg1_tree)),
4941                               arg1_tree);
4942
4943         /* Pass procedure as a pointer to it, anything else by value.  */
4944         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4945           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4946         else
4947           arg2_tree = ffecom_ptr_to_expr (arg2);
4948         arg2_tree = convert (TREE_TYPE (null_pointer_node),
4949                              arg2_tree);
4950
4951         if (arg3 != NULL)
4952           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4953         else
4954           arg3_tree = NULL_TREE;
4955
4956         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4957         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4958         TREE_CHAIN (arg1_tree) = arg2_tree;
4959
4960         expr_tree
4961           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4962                           ffecom_gfrt_kindtype (gfrt),
4963                           FALSE,
4964                           ((codegen_imp == FFEINTRIN_impSIGNAL_subr) ?
4965                            NULL_TREE :
4966                            tree_type),
4967                           arg1_tree,
4968                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4969                           ffebld_nonter_hook (expr));
4970
4971         if (arg3_tree != NULL_TREE)
4972           expr_tree
4973             = ffecom_modify (NULL_TREE, arg3_tree,
4974                              convert (TREE_TYPE (arg3_tree),
4975                                       expr_tree));
4976       }
4977       return expr_tree;
4978
4979     case FFEINTRIN_impALARM:
4980       {
4981         tree arg1_tree;
4982         tree arg2_tree;
4983         tree arg3_tree;
4984
4985         arg1_tree = convert (ffecom_f2c_integer_type_node,
4986                              ffecom_expr (arg1));
4987         arg1_tree = ffecom_1 (ADDR_EXPR,
4988                               build_pointer_type (TREE_TYPE (arg1_tree)),
4989                               arg1_tree);
4990
4991         /* Pass procedure as a pointer to it, anything else by value.  */
4992         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4993           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4994         else
4995           arg2_tree = ffecom_ptr_to_expr (arg2);
4996         arg2_tree = convert (TREE_TYPE (null_pointer_node),
4997                              arg2_tree);
4998
4999         if (arg3 != NULL)
5000           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5001         else
5002           arg3_tree = NULL_TREE;
5003
5004         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5005         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5006         TREE_CHAIN (arg1_tree) = arg2_tree;
5007
5008         expr_tree
5009           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5010                           ffecom_gfrt_kindtype (gfrt),
5011                           FALSE,
5012                           NULL_TREE,
5013                           arg1_tree,
5014                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5015                           ffebld_nonter_hook (expr));
5016
5017         if (arg3_tree != NULL_TREE)
5018           expr_tree
5019             = ffecom_modify (NULL_TREE, arg3_tree,
5020                              convert (TREE_TYPE (arg3_tree),
5021                                       expr_tree));
5022       }
5023       return expr_tree;
5024
5025     case FFEINTRIN_impCHDIR_subr:
5026     case FFEINTRIN_impFDATE_subr:
5027     case FFEINTRIN_impFGET_subr:
5028     case FFEINTRIN_impFPUT_subr:
5029     case FFEINTRIN_impGETCWD_subr:
5030     case FFEINTRIN_impHOSTNM_subr:
5031     case FFEINTRIN_impSYSTEM_subr:
5032     case FFEINTRIN_impUNLINK_subr:
5033       {
5034         tree arg1_len = integer_zero_node;
5035         tree arg1_tree;
5036         tree arg2_tree;
5037
5038         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5039
5040         if (arg2 != NULL)
5041           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
5042         else
5043           arg2_tree = NULL_TREE;
5044
5045         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5046         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5047         TREE_CHAIN (arg1_tree) = arg1_len;
5048
5049         expr_tree
5050           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5051                           ffecom_gfrt_kindtype (gfrt),
5052                           FALSE,
5053                           NULL_TREE,
5054                           arg1_tree,
5055                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5056                           ffebld_nonter_hook (expr));
5057
5058         if (arg2_tree != NULL_TREE)
5059           expr_tree
5060             = ffecom_modify (NULL_TREE, arg2_tree,
5061                              convert (TREE_TYPE (arg2_tree),
5062                                       expr_tree));
5063       }
5064       return expr_tree;
5065
5066     case FFEINTRIN_impEXIT:
5067       if (arg1 != NULL)
5068         break;
5069
5070       expr_tree = build_tree_list (NULL_TREE,
5071                                    ffecom_1 (ADDR_EXPR,
5072                                              build_pointer_type
5073                                              (ffecom_integer_type_node),
5074                                              integer_zero_node));
5075
5076       return
5077         ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5078                       ffecom_gfrt_kindtype (gfrt),
5079                       FALSE,
5080                       void_type_node,
5081                       expr_tree,
5082                       NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5083                       ffebld_nonter_hook (expr));
5084
5085     case FFEINTRIN_impFLUSH:
5086       if (arg1 == NULL)
5087         gfrt = FFECOM_gfrtFLUSH;
5088       else
5089         gfrt = FFECOM_gfrtFLUSH1;
5090       break;
5091
5092     case FFEINTRIN_impCHMOD_subr:
5093     case FFEINTRIN_impLINK_subr:
5094     case FFEINTRIN_impRENAME_subr:
5095     case FFEINTRIN_impSYMLNK_subr:
5096       {
5097         tree arg1_len = integer_zero_node;
5098         tree arg1_tree;
5099         tree arg2_len = integer_zero_node;
5100         tree arg2_tree;
5101         tree arg3_tree;
5102
5103         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5104         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
5105         if (arg3 != NULL)
5106           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5107         else
5108           arg3_tree = NULL_TREE;
5109
5110         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5111         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5112         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5113         arg2_len = build_tree_list (NULL_TREE, arg2_len);
5114         TREE_CHAIN (arg1_tree) = arg2_tree;
5115         TREE_CHAIN (arg2_tree) = arg1_len;
5116         TREE_CHAIN (arg1_len) = arg2_len;
5117         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5118                                   ffecom_gfrt_kindtype (gfrt),
5119                                   FALSE,
5120                                   NULL_TREE,
5121                                   arg1_tree,
5122                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5123                                   ffebld_nonter_hook (expr));
5124         if (arg3_tree != NULL_TREE)
5125           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5126                                      convert (TREE_TYPE (arg3_tree),
5127                                               expr_tree));
5128       }
5129       return expr_tree;
5130
5131     case FFEINTRIN_impLSTAT_subr:
5132     case FFEINTRIN_impSTAT_subr:
5133       {
5134         tree arg1_len = integer_zero_node;
5135         tree arg1_tree;
5136         tree arg2_tree;
5137         tree arg3_tree;
5138
5139         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5140
5141         arg2_tree = ffecom_ptr_to_expr (arg2);
5142
5143         if (arg3 != NULL)
5144           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5145         else
5146           arg3_tree = NULL_TREE;
5147
5148         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5149         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5150         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5151         TREE_CHAIN (arg1_tree) = arg2_tree;
5152         TREE_CHAIN (arg2_tree) = arg1_len;
5153         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5154                                   ffecom_gfrt_kindtype (gfrt),
5155                                   FALSE,
5156                                   NULL_TREE,
5157                                   arg1_tree,
5158                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5159                                   ffebld_nonter_hook (expr));
5160         if (arg3_tree != NULL_TREE)
5161           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5162                                      convert (TREE_TYPE (arg3_tree),
5163                                               expr_tree));
5164       }
5165       return expr_tree;
5166
5167     case FFEINTRIN_impFGETC_subr:
5168     case FFEINTRIN_impFPUTC_subr:
5169       {
5170         tree arg1_tree;
5171         tree arg2_tree;
5172         tree arg2_len = integer_zero_node;
5173         tree arg3_tree;
5174
5175         arg1_tree = convert (ffecom_f2c_integer_type_node,
5176                              ffecom_expr (arg1));
5177         arg1_tree = ffecom_1 (ADDR_EXPR,
5178                               build_pointer_type (TREE_TYPE (arg1_tree)),
5179                               arg1_tree);
5180
5181         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
5182         arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5183
5184         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5185         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5186         arg2_len = build_tree_list (NULL_TREE, arg2_len);
5187         TREE_CHAIN (arg1_tree) = arg2_tree;
5188         TREE_CHAIN (arg2_tree) = arg2_len;
5189
5190         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5191                                   ffecom_gfrt_kindtype (gfrt),
5192                                   FALSE,
5193                                   NULL_TREE,
5194                                   arg1_tree,
5195                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5196                                   ffebld_nonter_hook (expr));
5197         expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5198                                    convert (TREE_TYPE (arg3_tree),
5199                                             expr_tree));
5200       }
5201       return expr_tree;
5202
5203     case FFEINTRIN_impFSTAT_subr:
5204       {
5205         tree arg1_tree;
5206         tree arg2_tree;
5207         tree arg3_tree;
5208
5209         arg1_tree = convert (ffecom_f2c_integer_type_node,
5210                              ffecom_expr (arg1));
5211         arg1_tree = ffecom_1 (ADDR_EXPR,
5212                               build_pointer_type (TREE_TYPE (arg1_tree)),
5213                               arg1_tree);
5214
5215         arg2_tree = convert (ffecom_f2c_ptr_to_integer_type_node,
5216                              ffecom_ptr_to_expr (arg2));
5217
5218         if (arg3 == NULL)
5219           arg3_tree = NULL_TREE;
5220         else
5221           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5222
5223         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5224         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5225         TREE_CHAIN (arg1_tree) = arg2_tree;
5226         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5227                                   ffecom_gfrt_kindtype (gfrt),
5228                                   FALSE,
5229                                   NULL_TREE,
5230                                   arg1_tree,
5231                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5232                                   ffebld_nonter_hook (expr));
5233         if (arg3_tree != NULL_TREE) {
5234           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5235                                      convert (TREE_TYPE (arg3_tree),
5236                                               expr_tree));
5237         }
5238       }
5239       return expr_tree;
5240
5241     case FFEINTRIN_impKILL_subr:
5242       {
5243         tree arg1_tree;
5244         tree arg2_tree;
5245         tree arg3_tree;
5246
5247         arg1_tree = convert (ffecom_f2c_integer_type_node,
5248                              ffecom_expr (arg1));
5249         arg1_tree = ffecom_1 (ADDR_EXPR,
5250                               build_pointer_type (TREE_TYPE (arg1_tree)),
5251                               arg1_tree);
5252
5253         arg2_tree = convert (ffecom_f2c_integer_type_node,
5254                              ffecom_expr (arg2));
5255         arg2_tree = ffecom_1 (ADDR_EXPR,
5256                               build_pointer_type (TREE_TYPE (arg2_tree)),
5257                               arg2_tree);
5258
5259         if (arg3 == NULL)
5260           arg3_tree = NULL_TREE;
5261         else
5262           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5263
5264         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5265         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5266         TREE_CHAIN (arg1_tree) = arg2_tree;
5267         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5268                                   ffecom_gfrt_kindtype (gfrt),
5269                                   FALSE,
5270                                   NULL_TREE,
5271                                   arg1_tree,
5272                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5273                                   ffebld_nonter_hook (expr));
5274         if (arg3_tree != NULL_TREE) {
5275           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5276                                      convert (TREE_TYPE (arg3_tree),
5277                                               expr_tree));
5278         }
5279       }
5280       return expr_tree;
5281
5282     case FFEINTRIN_impCTIME_subr:
5283     case FFEINTRIN_impTTYNAM_subr:
5284       {
5285         tree arg1_len = integer_zero_node;
5286         tree arg1_tree;
5287         tree arg2_tree;
5288
5289         arg1_tree = ffecom_arg_ptr_to_expr (arg2, &arg1_len);
5290
5291         arg2_tree = convert (((codegen_imp == FFEINTRIN_impCTIME_subr) ?
5292                               ffecom_f2c_longint_type_node :
5293                               ffecom_f2c_integer_type_node),
5294                              ffecom_expr (arg1));
5295         arg2_tree = ffecom_1 (ADDR_EXPR,
5296                               build_pointer_type (TREE_TYPE (arg2_tree)),
5297                               arg2_tree);
5298
5299         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5300         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5301         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5302         TREE_CHAIN (arg1_len) = arg2_tree;
5303         TREE_CHAIN (arg1_tree) = arg1_len;
5304
5305         expr_tree
5306           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5307                           ffecom_gfrt_kindtype (gfrt),
5308                           FALSE,
5309                           NULL_TREE,
5310                           arg1_tree,
5311                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5312                           ffebld_nonter_hook (expr));
5313         TREE_SIDE_EFFECTS (expr_tree) = 1;
5314       }
5315       return expr_tree;
5316
5317     case FFEINTRIN_impIRAND:
5318     case FFEINTRIN_impRAND:
5319       /* Arg defaults to 0 (normal random case) */
5320       {
5321         tree arg1_tree;
5322
5323         if (arg1 == NULL)
5324           arg1_tree = ffecom_integer_zero_node;
5325         else
5326           arg1_tree = ffecom_expr (arg1);
5327         arg1_tree = convert (ffecom_f2c_integer_type_node,
5328                              arg1_tree);
5329         arg1_tree = ffecom_1 (ADDR_EXPR,
5330                               build_pointer_type (TREE_TYPE (arg1_tree)),
5331                               arg1_tree);
5332         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5333
5334         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5335                                   ffecom_gfrt_kindtype (gfrt),
5336                                   FALSE,
5337                                   ((codegen_imp == FFEINTRIN_impIRAND) ?
5338                                    ffecom_f2c_integer_type_node :
5339                                    ffecom_f2c_real_type_node),
5340                                   arg1_tree,
5341                                   dest_tree, dest, dest_used,
5342                                   NULL_TREE, TRUE,
5343                                   ffebld_nonter_hook (expr));
5344       }
5345       return expr_tree;
5346
5347     case FFEINTRIN_impFTELL_subr:
5348     case FFEINTRIN_impUMASK_subr:
5349       {
5350         tree arg1_tree;
5351         tree arg2_tree;
5352
5353         arg1_tree = convert (ffecom_f2c_integer_type_node,
5354                              ffecom_expr (arg1));
5355         arg1_tree = ffecom_1 (ADDR_EXPR,
5356                               build_pointer_type (TREE_TYPE (arg1_tree)),
5357                               arg1_tree);
5358
5359         if (arg2 == NULL)
5360           arg2_tree = NULL_TREE;
5361         else
5362           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
5363
5364         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5365                                   ffecom_gfrt_kindtype (gfrt),
5366                                   FALSE,
5367                                   NULL_TREE,
5368                                   build_tree_list (NULL_TREE, arg1_tree),
5369                                   NULL_TREE, NULL, NULL, NULL_TREE,
5370                                   TRUE,
5371                                   ffebld_nonter_hook (expr));
5372         if (arg2_tree != NULL_TREE) {
5373           expr_tree = ffecom_modify (NULL_TREE, arg2_tree,
5374                                      convert (TREE_TYPE (arg2_tree),
5375                                               expr_tree));
5376         }
5377       }
5378       return expr_tree;
5379
5380     case FFEINTRIN_impCPU_TIME:
5381     case FFEINTRIN_impSECOND_subr:
5382       {
5383         tree arg1_tree;
5384
5385         arg1_tree = ffecom_expr_w (NULL_TREE, arg1);
5386
5387         expr_tree
5388           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5389                           ffecom_gfrt_kindtype (gfrt),
5390                           FALSE,
5391                           NULL_TREE,
5392                           NULL_TREE,
5393                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5394                           ffebld_nonter_hook (expr));
5395
5396         expr_tree
5397           = ffecom_modify (NULL_TREE, arg1_tree,
5398                            convert (TREE_TYPE (arg1_tree),
5399                                     expr_tree));
5400       }
5401       return expr_tree;
5402
5403     case FFEINTRIN_impDTIME_subr:
5404     case FFEINTRIN_impETIME_subr:
5405       {
5406         tree arg1_tree;
5407         tree result_tree;
5408
5409         result_tree = ffecom_expr_w (NULL_TREE, arg2);
5410
5411         arg1_tree = ffecom_ptr_to_expr (arg1);
5412
5413         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5414                                   ffecom_gfrt_kindtype (gfrt),
5415                                   FALSE,
5416                                   NULL_TREE,
5417                                   build_tree_list (NULL_TREE, arg1_tree),
5418                                   NULL_TREE, NULL, NULL, NULL_TREE,
5419                                   TRUE,
5420                                   ffebld_nonter_hook (expr));
5421         expr_tree = ffecom_modify (NULL_TREE, result_tree,
5422                                    convert (TREE_TYPE (result_tree),
5423                                             expr_tree));
5424       }
5425       return expr_tree;
5426
5427       /* Straightforward calls of libf2c routines: */
5428     case FFEINTRIN_impABORT:
5429     case FFEINTRIN_impACCESS:
5430     case FFEINTRIN_impBESJ0:
5431     case FFEINTRIN_impBESJ1:
5432     case FFEINTRIN_impBESJN:
5433     case FFEINTRIN_impBESY0:
5434     case FFEINTRIN_impBESY1:
5435     case FFEINTRIN_impBESYN:
5436     case FFEINTRIN_impCHDIR_func:
5437     case FFEINTRIN_impCHMOD_func:
5438     case FFEINTRIN_impDATE:
5439     case FFEINTRIN_impDATE_AND_TIME:
5440     case FFEINTRIN_impDBESJ0:
5441     case FFEINTRIN_impDBESJ1:
5442     case FFEINTRIN_impDBESJN:
5443     case FFEINTRIN_impDBESY0:
5444     case FFEINTRIN_impDBESY1:
5445     case FFEINTRIN_impDBESYN:
5446     case FFEINTRIN_impDTIME_func:
5447     case FFEINTRIN_impETIME_func:
5448     case FFEINTRIN_impFGETC_func:
5449     case FFEINTRIN_impFGET_func:
5450     case FFEINTRIN_impFNUM:
5451     case FFEINTRIN_impFPUTC_func:
5452     case FFEINTRIN_impFPUT_func:
5453     case FFEINTRIN_impFSEEK:
5454     case FFEINTRIN_impFSTAT_func:
5455     case FFEINTRIN_impFTELL_func:
5456     case FFEINTRIN_impGERROR:
5457     case FFEINTRIN_impGETARG:
5458     case FFEINTRIN_impGETCWD_func:
5459     case FFEINTRIN_impGETENV:
5460     case FFEINTRIN_impGETGID:
5461     case FFEINTRIN_impGETLOG:
5462     case FFEINTRIN_impGETPID:
5463     case FFEINTRIN_impGETUID:
5464     case FFEINTRIN_impGMTIME:
5465     case FFEINTRIN_impHOSTNM_func:
5466     case FFEINTRIN_impIDATE_unix:
5467     case FFEINTRIN_impIDATE_vxt:
5468     case FFEINTRIN_impIERRNO:
5469     case FFEINTRIN_impISATTY:
5470     case FFEINTRIN_impITIME:
5471     case FFEINTRIN_impKILL_func:
5472     case FFEINTRIN_impLINK_func:
5473     case FFEINTRIN_impLNBLNK:
5474     case FFEINTRIN_impLSTAT_func:
5475     case FFEINTRIN_impLTIME:
5476     case FFEINTRIN_impMCLOCK8:
5477     case FFEINTRIN_impMCLOCK:
5478     case FFEINTRIN_impPERROR:
5479     case FFEINTRIN_impRENAME_func:
5480     case FFEINTRIN_impSECNDS:
5481     case FFEINTRIN_impSECOND_func:
5482     case FFEINTRIN_impSLEEP:
5483     case FFEINTRIN_impSRAND:
5484     case FFEINTRIN_impSTAT_func:
5485     case FFEINTRIN_impSYMLNK_func:
5486     case FFEINTRIN_impSYSTEM_CLOCK:
5487     case FFEINTRIN_impSYSTEM_func:
5488     case FFEINTRIN_impTIME8:
5489     case FFEINTRIN_impTIME_unix:
5490     case FFEINTRIN_impTIME_vxt:
5491     case FFEINTRIN_impUMASK_func:
5492     case FFEINTRIN_impUNLINK_func:
5493       break;
5494
5495     case FFEINTRIN_impCTIME_func:       /* CHARACTER functions not handled here. */
5496     case FFEINTRIN_impFDATE_func:       /* CHARACTER functions not handled here. */
5497     case FFEINTRIN_impTTYNAM_func:      /* CHARACTER functions not handled here. */
5498     case FFEINTRIN_impNONE:
5499     case FFEINTRIN_imp:         /* Hush up gcc warning. */
5500       fprintf (stderr, "No %s implementation.\n",
5501                ffeintrin_name_implementation (ffebld_symter_implementation (ffebld_left (expr))));
5502       assert ("unimplemented intrinsic" == NULL);
5503       return error_mark_node;
5504     }
5505
5506   assert (gfrt != FFECOM_gfrt); /* Must have an implementation! */
5507
5508   expr_tree = ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt),
5509                                     ffebld_right (expr));
5510
5511   return ffecom_call_ (ffecom_gfrt_tree_ (gfrt), ffecom_gfrt_kindtype (gfrt),
5512                        (ffe_is_f2c_library () && ffecom_gfrt_complex_[gfrt]),
5513                        tree_type,
5514                        expr_tree, dest_tree, dest, dest_used,
5515                        NULL_TREE, TRUE,
5516                        ffebld_nonter_hook (expr));
5517
5518   /* See bottom of this file for f2c transforms used to determine
5519      many of the above implementations.  The info seems to confuse
5520      Emacs's C mode indentation, which is why it's been moved to
5521      the bottom of this source file.  */
5522 }
5523
5524 #endif
5525 /* For power (exponentiation) where right-hand operand is type INTEGER,
5526    generate in-line code to do it the fast way (which, if the operand
5527    is a constant, might just mean a series of multiplies).  */
5528
5529 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5530 static tree
5531 ffecom_expr_power_integer_ (ffebld expr)
5532 {
5533   tree l = ffecom_expr (ffebld_left (expr));
5534   tree r = ffecom_expr (ffebld_right (expr));
5535   tree ltype = TREE_TYPE (l);
5536   tree rtype = TREE_TYPE (r);
5537   tree result = NULL_TREE;
5538
5539   if (l == error_mark_node
5540       || r == error_mark_node)
5541     return error_mark_node;
5542
5543   if (TREE_CODE (r) == INTEGER_CST)
5544     {
5545       int sgn = tree_int_cst_sgn (r);
5546
5547       if (sgn == 0)
5548         return convert (ltype, integer_one_node);
5549
5550       if ((TREE_CODE (ltype) == INTEGER_TYPE)
5551           && (sgn < 0))
5552         {
5553           /* Reciprocal of integer is either 0, -1, or 1, so after
5554              calculating that (which we leave to the back end to do
5555              or not do optimally), don't bother with any multiplying.  */
5556
5557           result = ffecom_tree_divide_ (ltype,
5558                                         convert (ltype, integer_one_node),
5559                                         l,
5560                                         NULL_TREE, NULL, NULL, NULL_TREE);
5561           r = ffecom_1 (NEGATE_EXPR,
5562                         rtype,
5563                         r);
5564           if ((TREE_INT_CST_LOW (r) & 1) == 0)
5565             result = ffecom_1 (ABS_EXPR, rtype,
5566                                result);
5567         }
5568
5569       /* Generate appropriate series of multiplies, preceded
5570          by divide if the exponent is negative.  */
5571
5572       l = save_expr (l);
5573
5574       if (sgn < 0)
5575         {
5576           l = ffecom_tree_divide_ (ltype,
5577                                    convert (ltype, integer_one_node),
5578                                    l,
5579                                    NULL_TREE, NULL, NULL,
5580                                    ffebld_nonter_hook (expr));
5581           r = ffecom_1 (NEGATE_EXPR, rtype, r);
5582           assert (TREE_CODE (r) == INTEGER_CST);
5583
5584           if (tree_int_cst_sgn (r) < 0)
5585             {                   /* The "most negative" number.  */
5586               r = ffecom_1 (NEGATE_EXPR, rtype,
5587                             ffecom_2 (RSHIFT_EXPR, rtype,
5588                                       r,
5589                                       integer_one_node));
5590               l = save_expr (l);
5591               l = ffecom_2 (MULT_EXPR, ltype,
5592                             l,
5593                             l);
5594             }
5595         }
5596
5597       for (;;)
5598         {
5599           if (TREE_INT_CST_LOW (r) & 1)
5600             {
5601               if (result == NULL_TREE)
5602                 result = l;
5603               else
5604                 result = ffecom_2 (MULT_EXPR, ltype,
5605                                    result,
5606                                    l);
5607             }
5608
5609           r = ffecom_2 (RSHIFT_EXPR, rtype,
5610                         r,
5611                         integer_one_node);
5612           if (integer_zerop (r))
5613             break;
5614           assert (TREE_CODE (r) == INTEGER_CST);
5615
5616           l = save_expr (l);
5617           l = ffecom_2 (MULT_EXPR, ltype,
5618                         l,
5619                         l);
5620         }
5621       return result;
5622     }
5623
5624   /* Though rhs isn't a constant, in-line code cannot be expanded
5625      while transforming dummies
5626      because the back end cannot be easily convinced to generate
5627      stores (MODIFY_EXPR), handle temporaries, and so on before
5628      all the appropriate rtx's have been generated for things like
5629      dummy args referenced in rhs -- which doesn't happen until
5630      store_parm_decls() is called (expand_function_start, I believe,
5631      does the actual rtx-stuffing of PARM_DECLs).
5632
5633      So, in this case, let the caller generate the call to the
5634      run-time-library function to evaluate the power for us.  */
5635
5636   if (ffecom_transform_only_dummies_)
5637     return NULL_TREE;
5638
5639   /* Right-hand operand not a constant, expand in-line code to figure
5640      out how to do the multiplies, &c.
5641
5642      The returned expression is expressed this way in GNU C, where l and
5643      r are the "inputs":
5644
5645      ({ typeof (r) rtmp = r;
5646         typeof (l) ltmp = l;
5647         typeof (l) result;
5648
5649         if (rtmp == 0)
5650           result = 1;
5651         else
5652           {
5653             if ((basetypeof (l) == basetypeof (int))
5654                 && (rtmp < 0))
5655               {
5656                 result = ((typeof (l)) 1) / ltmp;
5657                 if ((ltmp < 0) && (((-rtmp) & 1) == 0))
5658                   result = -result;
5659               }
5660             else
5661               {
5662                 result = 1;
5663                 if ((basetypeof (l) != basetypeof (int))
5664                     && (rtmp < 0))
5665                   {
5666                     ltmp = ((typeof (l)) 1) / ltmp;
5667                     rtmp = -rtmp;
5668                     if (rtmp < 0)
5669                       {
5670                         rtmp = -(rtmp >> 1);
5671                         ltmp *= ltmp;
5672                       }
5673                   }
5674                 for (;;)
5675                   {
5676                     if (rtmp & 1)
5677                       result *= ltmp;
5678                     if ((rtmp >>= 1) == 0)
5679                       break;
5680                     ltmp *= ltmp;
5681                   }
5682               }
5683           }
5684         result;
5685      })
5686
5687      Note that some of the above is compile-time collapsable, such as
5688      the first part of the if statements that checks the base type of
5689      l against int.  The if statements are phrased that way to suggest
5690      an easy way to generate the if/else constructs here, knowing that
5691      the back end should (and probably does) eliminate the resulting
5692      dead code (either the int case or the non-int case), something
5693      it couldn't do without the redundant phrasing, requiring explicit
5694      dead-code elimination here, which would be kind of difficult to
5695      read.  */
5696
5697   {
5698     tree rtmp;
5699     tree ltmp;
5700     tree divide;
5701     tree basetypeof_l_is_int;
5702     tree se;
5703     tree t;
5704
5705     basetypeof_l_is_int
5706       = build_int_2 ((TREE_CODE (ltype) == INTEGER_TYPE), 0);
5707
5708     se = expand_start_stmt_expr ();
5709
5710     ffecom_start_compstmt ();
5711
5712 #ifndef HAHA
5713     rtmp = ffecom_make_tempvar ("power_r", rtype,
5714                                 FFETARGET_charactersizeNONE, -1);
5715     ltmp = ffecom_make_tempvar ("power_l", ltype,
5716                                 FFETARGET_charactersizeNONE, -1);
5717     result = ffecom_make_tempvar ("power_res", ltype,
5718                                   FFETARGET_charactersizeNONE, -1);
5719     if (TREE_CODE (ltype) == COMPLEX_TYPE
5720         || TREE_CODE (ltype) == RECORD_TYPE)
5721       divide = ffecom_make_tempvar ("power_div", ltype,
5722                                     FFETARGET_charactersizeNONE, -1);
5723     else
5724       divide = NULL_TREE;
5725 #else  /* HAHA */
5726     {
5727       tree hook;
5728
5729       hook = ffebld_nonter_hook (expr);
5730       assert (hook);
5731       assert (TREE_CODE (hook) == TREE_VEC);
5732       assert (TREE_VEC_LENGTH (hook) == 4);
5733       rtmp = TREE_VEC_ELT (hook, 0);
5734       ltmp = TREE_VEC_ELT (hook, 1);
5735       result = TREE_VEC_ELT (hook, 2);
5736       divide = TREE_VEC_ELT (hook, 3);
5737       if (TREE_CODE (ltype) == COMPLEX_TYPE
5738           || TREE_CODE (ltype) == RECORD_TYPE)
5739         assert (divide);
5740       else
5741         assert (! divide);
5742     }
5743 #endif  /* HAHA */
5744
5745     expand_expr_stmt (ffecom_modify (void_type_node,
5746                                      rtmp,
5747                                      r));
5748     expand_expr_stmt (ffecom_modify (void_type_node,
5749                                      ltmp,
5750                                      l));
5751     expand_start_cond (ffecom_truth_value
5752                        (ffecom_2 (EQ_EXPR, integer_type_node,
5753                                   rtmp,
5754                                   convert (rtype, integer_zero_node))),
5755                        0);
5756     expand_expr_stmt (ffecom_modify (void_type_node,
5757                                      result,
5758                                      convert (ltype, integer_one_node)));
5759     expand_start_else ();
5760     if (! integer_zerop (basetypeof_l_is_int))
5761       {
5762         expand_start_cond (ffecom_2 (LT_EXPR, integer_type_node,
5763                                      rtmp,
5764                                      convert (rtype,
5765                                               integer_zero_node)),
5766                            0);
5767         expand_expr_stmt (ffecom_modify (void_type_node,
5768                                          result,
5769                                          ffecom_tree_divide_
5770                                          (ltype,
5771                                           convert (ltype, integer_one_node),
5772                                           ltmp,
5773                                           NULL_TREE, NULL, NULL,
5774                                           divide)));
5775         expand_start_cond (ffecom_truth_value
5776                            (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5777                                       ffecom_2 (LT_EXPR, integer_type_node,
5778                                                 ltmp,
5779                                                 convert (ltype,
5780                                                          integer_zero_node)),
5781                                       ffecom_2 (EQ_EXPR, integer_type_node,
5782                                                 ffecom_2 (BIT_AND_EXPR,
5783                                                           rtype,
5784                                                           ffecom_1 (NEGATE_EXPR,
5785                                                                     rtype,
5786                                                                     rtmp),
5787                                                           convert (rtype,
5788                                                                    integer_one_node)),
5789                                                 convert (rtype,
5790                                                          integer_zero_node)))),
5791                            0);
5792         expand_expr_stmt (ffecom_modify (void_type_node,
5793                                          result,
5794                                          ffecom_1 (NEGATE_EXPR,
5795                                                    ltype,
5796                                                    result)));
5797         expand_end_cond ();
5798         expand_start_else ();
5799       }
5800     expand_expr_stmt (ffecom_modify (void_type_node,
5801                                      result,
5802                                      convert (ltype, integer_one_node)));
5803     expand_start_cond (ffecom_truth_value
5804                        (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5805                                   ffecom_truth_value_invert
5806                                   (basetypeof_l_is_int),
5807                                   ffecom_2 (LT_EXPR, integer_type_node,
5808                                             rtmp,
5809                                             convert (rtype,
5810                                                      integer_zero_node)))),
5811                        0);
5812     expand_expr_stmt (ffecom_modify (void_type_node,
5813                                      ltmp,
5814                                      ffecom_tree_divide_
5815                                      (ltype,
5816                                       convert (ltype, integer_one_node),
5817                                       ltmp,
5818                                       NULL_TREE, NULL, NULL,
5819                                       divide)));
5820     expand_expr_stmt (ffecom_modify (void_type_node,
5821                                      rtmp,
5822                                      ffecom_1 (NEGATE_EXPR, rtype,
5823                                                rtmp)));
5824     expand_start_cond (ffecom_truth_value
5825                        (ffecom_2 (LT_EXPR, integer_type_node,
5826                                   rtmp,
5827                                   convert (rtype, integer_zero_node))),
5828                        0);
5829     expand_expr_stmt (ffecom_modify (void_type_node,
5830                                      rtmp,
5831                                      ffecom_1 (NEGATE_EXPR, rtype,
5832                                                ffecom_2 (RSHIFT_EXPR,
5833                                                          rtype,
5834                                                          rtmp,
5835                                                          integer_one_node))));
5836     expand_expr_stmt (ffecom_modify (void_type_node,
5837                                      ltmp,
5838                                      ffecom_2 (MULT_EXPR, ltype,
5839                                                ltmp,
5840                                                ltmp)));
5841     expand_end_cond ();
5842     expand_end_cond ();
5843     expand_start_loop (1);
5844     expand_start_cond (ffecom_truth_value
5845                        (ffecom_2 (BIT_AND_EXPR, rtype,
5846                                   rtmp,
5847                                   convert (rtype, integer_one_node))),
5848                        0);
5849     expand_expr_stmt (ffecom_modify (void_type_node,
5850                                      result,
5851                                      ffecom_2 (MULT_EXPR, ltype,
5852                                                result,
5853                                                ltmp)));
5854     expand_end_cond ();
5855     expand_exit_loop_if_false (NULL,
5856                                ffecom_truth_value
5857                                (ffecom_modify (rtype,
5858                                                rtmp,
5859                                                ffecom_2 (RSHIFT_EXPR,
5860                                                          rtype,
5861                                                          rtmp,
5862                                                          integer_one_node))));
5863     expand_expr_stmt (ffecom_modify (void_type_node,
5864                                      ltmp,
5865                                      ffecom_2 (MULT_EXPR, ltype,
5866                                                ltmp,
5867                                                ltmp)));
5868     expand_end_loop ();
5869     expand_end_cond ();
5870     if (!integer_zerop (basetypeof_l_is_int))
5871       expand_end_cond ();
5872     expand_expr_stmt (result);
5873
5874     t = ffecom_end_compstmt ();
5875
5876     result = expand_end_stmt_expr (se);
5877
5878     /* This code comes from c-parse.in, after its expand_end_stmt_expr.  */
5879
5880     if (TREE_CODE (t) == BLOCK)
5881       {
5882         /* Make a BIND_EXPR for the BLOCK already made.  */
5883         result = build (BIND_EXPR, TREE_TYPE (result),
5884                         NULL_TREE, result, t);
5885         /* Remove the block from the tree at this point.
5886            It gets put back at the proper place
5887            when the BIND_EXPR is expanded.  */
5888         delete_block (t);
5889       }
5890     else
5891       result = t;
5892   }
5893
5894   return result;
5895 }
5896
5897 #endif
5898 /* ffecom_expr_transform_ -- Transform symbols in expr
5899
5900    ffebld expr;  // FFE expression.
5901    ffecom_expr_transform_ (expr);
5902
5903    Recursive descent on expr while transforming any untransformed SYMTERs.  */
5904
5905 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5906 static void
5907 ffecom_expr_transform_ (ffebld expr)
5908 {
5909   tree t;
5910   ffesymbol s;
5911
5912 tail_recurse:                   /* :::::::::::::::::::: */
5913
5914   if (expr == NULL)
5915     return;
5916
5917   switch (ffebld_op (expr))
5918     {
5919     case FFEBLD_opSYMTER:
5920       s = ffebld_symter (expr);
5921       t = ffesymbol_hook (s).decl_tree;
5922       if ((t == NULL_TREE)
5923           && ((ffesymbol_kind (s) != FFEINFO_kindNONE)
5924               || ((ffesymbol_where (s) != FFEINFO_whereNONE)
5925                   && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC))))
5926         {
5927           s = ffecom_sym_transform_ (s);
5928           t = ffesymbol_hook (s).decl_tree;     /* Sfunc expr non-dummy,
5929                                                    DIMENSION expr? */
5930         }
5931       break;                    /* Ok if (t == NULL) here. */
5932
5933     case FFEBLD_opITEM:
5934       ffecom_expr_transform_ (ffebld_head (expr));
5935       expr = ffebld_trail (expr);
5936       goto tail_recurse;        /* :::::::::::::::::::: */
5937
5938     default:
5939       break;
5940     }
5941
5942   switch (ffebld_arity (expr))
5943     {
5944     case 2:
5945       ffecom_expr_transform_ (ffebld_left (expr));
5946       expr = ffebld_right (expr);
5947       goto tail_recurse;        /* :::::::::::::::::::: */
5948
5949     case 1:
5950       expr = ffebld_left (expr);
5951       goto tail_recurse;        /* :::::::::::::::::::: */
5952
5953     default:
5954       break;
5955     }
5956
5957   return;
5958 }
5959
5960 #endif
5961 /* Make a type based on info in live f2c.h file.  */
5962
5963 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5964 static void
5965 ffecom_f2c_make_type_ (tree *type, int tcode, const char *name)
5966 {
5967   switch (tcode)
5968     {
5969     case FFECOM_f2ccodeCHAR:
5970       *type = make_signed_type (CHAR_TYPE_SIZE);
5971       break;
5972
5973     case FFECOM_f2ccodeSHORT:
5974       *type = make_signed_type (SHORT_TYPE_SIZE);
5975       break;
5976
5977     case FFECOM_f2ccodeINT:
5978       *type = make_signed_type (INT_TYPE_SIZE);
5979       break;
5980
5981     case FFECOM_f2ccodeLONG:
5982       *type = make_signed_type (LONG_TYPE_SIZE);
5983       break;
5984
5985     case FFECOM_f2ccodeLONGLONG:
5986       *type = make_signed_type (LONG_LONG_TYPE_SIZE);
5987       break;
5988
5989     case FFECOM_f2ccodeCHARPTR:
5990       *type = build_pointer_type (DEFAULT_SIGNED_CHAR
5991                                   ? signed_char_type_node
5992                                   : unsigned_char_type_node);
5993       break;
5994
5995     case FFECOM_f2ccodeFLOAT:
5996       *type = make_node (REAL_TYPE);
5997       TYPE_PRECISION (*type) = FLOAT_TYPE_SIZE;
5998       layout_type (*type);
5999       break;
6000
6001     case FFECOM_f2ccodeDOUBLE:
6002       *type = make_node (REAL_TYPE);
6003       TYPE_PRECISION (*type) = DOUBLE_TYPE_SIZE;
6004       layout_type (*type);
6005       break;
6006
6007     case FFECOM_f2ccodeLONGDOUBLE:
6008       *type = make_node (REAL_TYPE);
6009       TYPE_PRECISION (*type) = LONG_DOUBLE_TYPE_SIZE;
6010       layout_type (*type);
6011       break;
6012
6013     case FFECOM_f2ccodeTWOREALS:
6014       *type = ffecom_make_complex_type_ (ffecom_f2c_real_type_node);
6015       break;
6016
6017     case FFECOM_f2ccodeTWODOUBLEREALS:
6018       *type = ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node);
6019       break;
6020
6021     default:
6022       assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL);
6023       *type = error_mark_node;
6024       return;
6025     }
6026
6027   pushdecl (build_decl (TYPE_DECL,
6028                         ffecom_get_invented_identifier ("__g77_f2c_%s", name),
6029                         *type));
6030 }
6031
6032 #endif
6033 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6034 /* Set the f2c list-directed-I/O code for whatever (integral) type has the
6035    given size.  */
6036
6037 static void
6038 ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
6039                           int code)
6040 {
6041   int j;
6042   tree t;
6043
6044   for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
6045     if ((t = ffecom_tree_type[bt][j]) != NULL_TREE
6046         && compare_tree_int (TYPE_SIZE (t), size) == 0)
6047       {
6048         assert (code != -1);
6049         ffecom_f2c_typecode_[bt][j] = code;
6050         code = -1;
6051       }
6052 }
6053
6054 #endif
6055 /* Finish up globals after doing all program units in file
6056
6057    Need to handle only uninitialized COMMON areas.  */
6058
6059 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6060 static ffeglobal
6061 ffecom_finish_global_ (ffeglobal global)
6062 {
6063   tree cbtype;
6064   tree cbt;
6065   tree size;
6066
6067   if (ffeglobal_type (global) != FFEGLOBAL_typeCOMMON)
6068       return global;
6069
6070   if (ffeglobal_common_init (global))
6071       return global;
6072
6073   cbt = ffeglobal_hook (global);
6074   if ((cbt == NULL_TREE)
6075       || !ffeglobal_common_have_size (global))
6076     return global;              /* No need to make common, never ref'd. */
6077
6078   suspend_momentary ();
6079
6080   DECL_EXTERNAL (cbt) = 0;
6081
6082   /* Give the array a size now.  */
6083
6084   size = build_int_2 ((ffeglobal_common_size (global)
6085                       + ffeglobal_common_pad (global)) - 1,
6086                       0);
6087
6088   cbtype = TREE_TYPE (cbt);
6089   TYPE_DOMAIN (cbtype) = build_range_type (integer_type_node,
6090                                            integer_zero_node,
6091                                            size);
6092   if (!TREE_TYPE (size))
6093     TREE_TYPE (size) = TYPE_DOMAIN (cbtype);
6094   layout_type (cbtype);
6095
6096   cbt = start_decl (cbt, FALSE);
6097   assert (cbt == ffeglobal_hook (global));
6098
6099   finish_decl (cbt, NULL_TREE, FALSE);
6100
6101   return global;
6102 }
6103
6104 #endif
6105 /* Finish up any untransformed symbols.  */
6106
6107 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6108 static ffesymbol
6109 ffecom_finish_symbol_transform_ (ffesymbol s)
6110 {
6111   if ((s == NULL) || (TREE_CODE (current_function_decl) == ERROR_MARK))
6112     return s;
6113
6114   /* It's easy to know to transform an untransformed symbol, to make sure
6115      we put out debugging info for it.  But COMMON variables, unlike
6116      EQUIVALENCE ones, aren't given declarations in addition to the
6117      tree expressions that specify offsets, because COMMON variables
6118      can be referenced in the outer scope where only dummy arguments
6119      (PARM_DECLs) should really be seen.  To be safe, just don't do any
6120      VAR_DECLs for COMMON variables when we transform them for real
6121      use, and therefore we do all the VAR_DECL creating here.  */
6122
6123   if (ffesymbol_hook (s).decl_tree == NULL_TREE)
6124     {
6125       if (ffesymbol_kind (s) != FFEINFO_kindNONE
6126           || (ffesymbol_where (s) != FFEINFO_whereNONE
6127               && ffesymbol_where (s) != FFEINFO_whereINTRINSIC
6128               && ffesymbol_where (s) != FFEINFO_whereDUMMY))
6129         /* Not transformed, and not CHARACTER*(*), and not a dummy
6130            argument, which can happen only if the entry point names
6131            it "rides in on" are all invalidated for other reasons.  */
6132         s = ffecom_sym_transform_ (s);
6133     }
6134
6135   if ((ffesymbol_where (s) == FFEINFO_whereCOMMON)
6136       && (ffesymbol_hook (s).decl_tree != error_mark_node))
6137     {
6138       int yes = suspend_momentary ();
6139
6140       /* This isn't working, at least for dbxout.  The .s file looks
6141          okay to me (burley), but in gdb 4.9 at least, the variables
6142          appear to reside somewhere outside of the common area, so
6143          it doesn't make sense to mislead anyone by generating the info
6144          on those variables until this is fixed.  NOTE: Same problem
6145          with EQUIVALENCE, sadly...see similar #if later.  */
6146       ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s)),
6147                              ffesymbol_storage (s));
6148
6149       resume_momentary (yes);
6150     }
6151
6152   return s;
6153 }
6154
6155 #endif
6156 /* Append underscore(s) to name before calling get_identifier.  "us"
6157    is nonzero if the name already contains an underscore and thus
6158    needs two underscores appended.  */
6159
6160 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6161 static tree
6162 ffecom_get_appended_identifier_ (char us, const char *name)
6163 {
6164   int i;
6165   char *newname;
6166   tree id;
6167
6168   newname = xmalloc ((i = strlen (name)) + 1
6169                      + ffe_is_underscoring ()
6170                      + us);
6171   memcpy (newname, name, i);
6172   newname[i] = '_';
6173   newname[i + us] = '_';
6174   newname[i + 1 + us] = '\0';
6175   id = get_identifier (newname);
6176
6177   free (newname);
6178
6179   return id;
6180 }
6181
6182 #endif
6183 /* Decide whether to append underscore to name before calling
6184    get_identifier.  */
6185
6186 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6187 static tree
6188 ffecom_get_external_identifier_ (ffesymbol s)
6189 {
6190   char us;
6191   const char *name = ffesymbol_text (s);
6192
6193   /* If name is a built-in name, just return it as is.  */
6194
6195   if (!ffe_is_underscoring ()
6196       || (strcmp (name, FFETARGET_nameBLANK_COMMON) == 0)
6197 #if FFETARGET_isENFORCED_MAIN_NAME
6198       || (strcmp (name, FFETARGET_nameENFORCED_NAME) == 0)
6199 #else
6200       || (strcmp (name, FFETARGET_nameUNNAMED_MAIN) == 0)
6201 #endif
6202       || (strcmp (name, FFETARGET_nameUNNAMED_BLOCK_DATA) == 0))
6203     return get_identifier (name);
6204
6205   us = ffe_is_second_underscore ()
6206     ? (strchr (name, '_') != NULL)
6207       : 0;
6208
6209   return ffecom_get_appended_identifier_ (us, name);
6210 }
6211
6212 #endif
6213 /* Decide whether to append underscore to internal name before calling
6214    get_identifier.
6215
6216    This is for non-external, top-function-context names only.  Transform
6217    identifier so it doesn't conflict with the transformed result
6218    of using a _different_ external name.  E.g. if "CALL FOO" is
6219    transformed into "FOO_();", then the variable in "FOO_ = 3"
6220    must be transformed into something that does not conflict, since
6221    these two things should be independent.
6222
6223    The transformation is as follows.  If the name does not contain
6224    an underscore, there is no possible conflict, so just return.
6225    If the name does contain an underscore, then transform it just
6226    like we transform an external identifier.  */
6227
6228 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6229 static tree
6230 ffecom_get_identifier_ (const char *name)
6231 {
6232   /* If name does not contain an underscore, just return it as is.  */
6233
6234   if (!ffe_is_underscoring ()
6235       || (strchr (name, '_') == NULL))
6236     return get_identifier (name);
6237
6238   return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
6239                                           name);
6240 }
6241
6242 #endif
6243 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
6244
6245    tree t;
6246    ffesymbol s;  // kindFUNCTION, whereIMMEDIATE.
6247    t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
6248          ffesymbol_kindtype(s));
6249
6250    Call after setting up containing function and getting trees for all
6251    other symbols.  */
6252
6253 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6254 static tree
6255 ffecom_gen_sfuncdef_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt)
6256 {
6257   ffebld expr = ffesymbol_sfexpr (s);
6258   tree type;
6259   tree func;
6260   tree result;
6261   bool charfunc = (bt == FFEINFO_basictypeCHARACTER);
6262   static bool recurse = FALSE;
6263   int yes;
6264   int old_lineno = lineno;
6265   char *old_input_filename = input_filename;
6266
6267   ffecom_nested_entry_ = s;
6268
6269   /* For now, we don't have a handy pointer to where the sfunc is actually
6270      defined, though that should be easy to add to an ffesymbol. (The
6271      token/where info available might well point to the place where the type
6272      of the sfunc is declared, especially if that precedes the place where
6273      the sfunc itself is defined, which is typically the case.)  We should
6274      put out a null pointer rather than point somewhere wrong, but I want to
6275      see how it works at this point.  */
6276
6277   input_filename = ffesymbol_where_filename (s);
6278   lineno = ffesymbol_where_filelinenum (s);
6279
6280   /* Pretransform the expression so any newly discovered things belong to the
6281      outer program unit, not to the statement function. */
6282
6283   ffecom_expr_transform_ (expr);
6284
6285   /* Make sure no recursive invocation of this fn (a specific case of failing
6286      to pretransform an sfunc's expression, i.e. where its expression
6287      references another untransformed sfunc) happens. */
6288
6289   assert (!recurse);
6290   recurse = TRUE;
6291
6292   yes = suspend_momentary ();
6293
6294   push_f_function_context ();
6295
6296   if (charfunc)
6297     type = void_type_node;
6298   else
6299     {
6300       type = ffecom_tree_type[bt][kt];
6301       if (type == NULL_TREE)
6302         type = integer_type_node;       /* _sym_exec_transition reports
6303                                            error. */
6304     }
6305
6306   start_function (ffecom_get_identifier_ (ffesymbol_text (s)),
6307                   build_function_type (type, NULL_TREE),
6308                   1,            /* nested/inline */
6309                   0);           /* TREE_PUBLIC */
6310
6311   /* We don't worry about COMPLEX return values here, because this is
6312      entirely internal to our code, and gcc has the ability to return COMPLEX
6313      directly as a value.  */
6314
6315   yes = suspend_momentary ();
6316
6317   if (charfunc)
6318     {                           /* Prepend arg for where result goes. */
6319       tree type;
6320
6321       type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
6322
6323       result = ffecom_get_invented_identifier ("__g77_%s", "result");
6324
6325       ffecom_char_enhance_arg_ (&type, s);      /* Ignore returned length. */
6326
6327       type = build_pointer_type (type);
6328       result = build_decl (PARM_DECL, result, type);
6329
6330       push_parm_decl (result);
6331     }
6332   else
6333     result = NULL_TREE;         /* Not ref'd if !charfunc. */
6334
6335   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s), TRUE);
6336
6337   resume_momentary (yes);
6338
6339   store_parm_decls (0);
6340
6341   ffecom_start_compstmt ();
6342
6343   if (expr != NULL)
6344     {
6345       if (charfunc)
6346         {
6347           ffetargetCharacterSize sz = ffesymbol_size (s);
6348           tree result_length;
6349
6350           result_length = build_int_2 (sz, 0);
6351           TREE_TYPE (result_length) = ffecom_f2c_ftnlen_type_node;
6352
6353           ffecom_prepare_let_char_ (sz, expr);
6354
6355           ffecom_prepare_end ();
6356
6357           ffecom_let_char_ (result, result_length, sz, expr);
6358           expand_null_return ();
6359         }
6360       else
6361         {
6362           ffecom_prepare_expr (expr);
6363
6364           ffecom_prepare_end ();
6365
6366           expand_return (ffecom_modify (NULL_TREE,
6367                                         DECL_RESULT (current_function_decl),
6368                                         ffecom_expr (expr)));
6369         }
6370
6371       clear_momentary ();
6372     }
6373
6374   ffecom_end_compstmt ();
6375
6376   func = current_function_decl;
6377   finish_function (1);
6378
6379   pop_f_function_context ();
6380
6381   resume_momentary (yes);
6382
6383   recurse = FALSE;
6384
6385   lineno = old_lineno;
6386   input_filename = old_input_filename;
6387
6388   ffecom_nested_entry_ = NULL;
6389
6390   return func;
6391 }
6392
6393 #endif
6394
6395 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6396 static const char *
6397 ffecom_gfrt_args_ (ffecomGfrt ix)
6398 {
6399   return ffecom_gfrt_argstring_[ix];
6400 }
6401
6402 #endif
6403 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6404 static tree
6405 ffecom_gfrt_tree_ (ffecomGfrt ix)
6406 {
6407   if (ffecom_gfrt_[ix] == NULL_TREE)
6408     ffecom_make_gfrt_ (ix);
6409
6410   return ffecom_1 (ADDR_EXPR,
6411                    build_pointer_type (TREE_TYPE (ffecom_gfrt_[ix])),
6412                    ffecom_gfrt_[ix]);
6413 }
6414
6415 #endif
6416 /* Return initialize-to-zero expression for this VAR_DECL.  */
6417
6418 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6419 /* A somewhat evil way to prevent the garbage collector
6420    from collecting 'tree' structures.  */
6421 #define NUM_TRACKED_CHUNK 63
6422 static struct tree_ggc_tracker
6423 {
6424   struct tree_ggc_tracker *next;
6425   tree trees[NUM_TRACKED_CHUNK];
6426 } *tracker_head = NULL;
6427
6428 static void
6429 mark_tracker_head (void *arg)
6430 {
6431   struct tree_ggc_tracker *head;
6432   int i;
6433
6434   for (head = * (struct tree_ggc_tracker **) arg;
6435        head != NULL;
6436        head = head->next)
6437   {
6438     ggc_mark (head);
6439     for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6440       ggc_mark_tree (head->trees[i]);
6441   }
6442 }
6443
6444 void
6445 ffecom_save_tree_forever (tree t)
6446 {
6447   int i;
6448   if (tracker_head != NULL)
6449     for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6450       if (tracker_head->trees[i] == NULL)
6451         {
6452           tracker_head->trees[i] = t;
6453           return;
6454         }
6455
6456   {
6457     /* Need to allocate a new block.  */
6458     struct tree_ggc_tracker *old_head = tracker_head;
6459
6460     tracker_head = ggc_alloc (sizeof (*tracker_head));
6461     tracker_head->next = old_head;
6462     tracker_head->trees[0] = t;
6463     for (i = 1; i < NUM_TRACKED_CHUNK; i++)
6464       tracker_head->trees[i] = NULL;
6465   }
6466 }
6467
6468 static tree
6469 ffecom_init_zero_ (tree decl)
6470 {
6471   tree init;
6472   int incremental = TREE_STATIC (decl);
6473   tree type = TREE_TYPE (decl);
6474
6475   if (incremental)
6476     {
6477       make_decl_rtl (decl, NULL, TREE_PUBLIC (decl) ? 1 : 0);
6478       assemble_variable (decl, TREE_PUBLIC (decl) ? 1 : 0, 0, 1);
6479     }
6480
6481   push_momentary ();
6482
6483   if ((TREE_CODE (type) != ARRAY_TYPE)
6484       && (TREE_CODE (type) != RECORD_TYPE)
6485       && (TREE_CODE (type) != UNION_TYPE)
6486       && !incremental)
6487     init = convert (type, integer_zero_node);
6488   else if (!incremental)
6489     {
6490       int momentary = suspend_momentary ();
6491
6492       init = build (CONSTRUCTOR, type, NULL_TREE, NULL_TREE);
6493       TREE_CONSTANT (init) = 1;
6494       TREE_STATIC (init) = 1;
6495
6496       resume_momentary (momentary);
6497     }
6498   else
6499     {
6500       int momentary = suspend_momentary ();
6501
6502       assemble_zeros (int_size_in_bytes (type));
6503       init = error_mark_node;
6504
6505       resume_momentary (momentary);
6506     }
6507
6508   pop_momentary_nofree ();
6509
6510   return init;
6511 }
6512
6513 #endif
6514 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6515 static tree
6516 ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
6517                          tree *maybe_tree)
6518 {
6519   tree expr_tree;
6520   tree length_tree;
6521
6522   switch (ffebld_op (arg))
6523     {
6524     case FFEBLD_opCONTER:       /* For F90, check 0-length. */
6525       if (ffetarget_length_character1
6526           (ffebld_constant_character1
6527            (ffebld_conter (arg))) == 0)
6528         {
6529           *maybe_tree = integer_zero_node;
6530           return convert (tree_type, integer_zero_node);
6531         }
6532
6533       *maybe_tree = integer_one_node;
6534       expr_tree = build_int_2 (*ffetarget_text_character1
6535                                (ffebld_constant_character1
6536                                 (ffebld_conter (arg))),
6537                                0);
6538       TREE_TYPE (expr_tree) = tree_type;
6539       return expr_tree;
6540
6541     case FFEBLD_opSYMTER:
6542     case FFEBLD_opARRAYREF:
6543     case FFEBLD_opFUNCREF:
6544     case FFEBLD_opSUBSTR:
6545       ffecom_char_args_ (&expr_tree, &length_tree, arg);
6546
6547       if ((expr_tree == error_mark_node)
6548           || (length_tree == error_mark_node))
6549         {
6550           *maybe_tree = error_mark_node;
6551           return error_mark_node;
6552         }
6553
6554       if (integer_zerop (length_tree))
6555         {
6556           *maybe_tree = integer_zero_node;
6557           return convert (tree_type, integer_zero_node);
6558         }
6559
6560       expr_tree
6561         = ffecom_1 (INDIRECT_REF,
6562                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6563                     expr_tree);
6564       expr_tree
6565         = ffecom_2 (ARRAY_REF,
6566                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6567                     expr_tree,
6568                     integer_one_node);
6569       expr_tree = convert (tree_type, expr_tree);
6570
6571       if (TREE_CODE (length_tree) == INTEGER_CST)
6572         *maybe_tree = integer_one_node;
6573       else                      /* Must check length at run time.  */
6574         *maybe_tree
6575           = ffecom_truth_value
6576             (ffecom_2 (GT_EXPR, integer_type_node,
6577                        length_tree,
6578                        ffecom_f2c_ftnlen_zero_node));
6579       return expr_tree;
6580
6581     case FFEBLD_opPAREN:
6582     case FFEBLD_opCONVERT:
6583       if (ffeinfo_size (ffebld_info (arg)) == 0)
6584         {
6585           *maybe_tree = integer_zero_node;
6586           return convert (tree_type, integer_zero_node);
6587         }
6588       return ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6589                                       maybe_tree);
6590
6591     case FFEBLD_opCONCATENATE:
6592       {
6593         tree maybe_left;
6594         tree maybe_right;
6595         tree expr_left;
6596         tree expr_right;
6597
6598         expr_left = ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6599                                              &maybe_left);
6600         expr_right = ffecom_intrinsic_ichar_ (tree_type, ffebld_right (arg),
6601                                               &maybe_right);
6602         *maybe_tree = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
6603                                 maybe_left,
6604                                 maybe_right);
6605         expr_tree = ffecom_3 (COND_EXPR, tree_type,
6606                               maybe_left,
6607                               expr_left,
6608                               expr_right);
6609         return expr_tree;
6610       }
6611
6612     default:
6613       assert ("bad op in ICHAR" == NULL);
6614       return error_mark_node;
6615     }
6616 }
6617
6618 #endif
6619 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
6620
6621    tree length_arg;
6622    ffebld expr;
6623    length_arg = ffecom_intrinsic_len_ (expr);
6624
6625    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
6626    subexpressions by constructing the appropriate tree for the
6627    length-of-character-text argument in a calling sequence.  */
6628
6629 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6630 static tree
6631 ffecom_intrinsic_len_ (ffebld expr)
6632 {
6633   ffetargetCharacter1 val;
6634   tree length;
6635
6636   switch (ffebld_op (expr))
6637     {
6638     case FFEBLD_opCONTER:
6639       val = ffebld_constant_character1 (ffebld_conter (expr));
6640       length = build_int_2 (ffetarget_length_character1 (val), 0);
6641       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6642       break;
6643
6644     case FFEBLD_opSYMTER:
6645       {
6646         ffesymbol s = ffebld_symter (expr);
6647         tree item;
6648
6649         item = ffesymbol_hook (s).decl_tree;
6650         if (item == NULL_TREE)
6651           {
6652             s = ffecom_sym_transform_ (s);
6653             item = ffesymbol_hook (s).decl_tree;
6654           }
6655         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
6656           {
6657             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
6658               length = ffesymbol_hook (s).length_tree;
6659             else
6660               {
6661                 length = build_int_2 (ffesymbol_size (s), 0);
6662                 TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6663               }
6664           }
6665         else if (item == error_mark_node)
6666           length = error_mark_node;
6667         else                    /* FFEINFO_kindFUNCTION: */
6668           length = NULL_TREE;
6669       }
6670       break;
6671
6672     case FFEBLD_opARRAYREF:
6673       length = ffecom_intrinsic_len_ (ffebld_left (expr));
6674       break;
6675
6676     case FFEBLD_opSUBSTR:
6677       {
6678         ffebld start;
6679         ffebld end;
6680         ffebld thing = ffebld_right (expr);
6681         tree start_tree;
6682         tree end_tree;
6683
6684         assert (ffebld_op (thing) == FFEBLD_opITEM);
6685         start = ffebld_head (thing);
6686         thing = ffebld_trail (thing);
6687         assert (ffebld_trail (thing) == NULL);
6688         end = ffebld_head (thing);
6689
6690         length = ffecom_intrinsic_len_ (ffebld_left (expr));
6691
6692         if (length == error_mark_node)
6693           break;
6694
6695         if (start == NULL)
6696           {
6697             if (end == NULL)
6698               ;
6699             else
6700               {
6701                 length = convert (ffecom_f2c_ftnlen_type_node,
6702                                   ffecom_expr (end));
6703               }
6704           }
6705         else
6706           {
6707             start_tree = convert (ffecom_f2c_ftnlen_type_node,
6708                                   ffecom_expr (start));
6709
6710             if (start_tree == error_mark_node)
6711               {
6712                 length = error_mark_node;
6713                 break;
6714               }
6715
6716             if (end == NULL)
6717               {
6718                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6719                                    ffecom_f2c_ftnlen_one_node,
6720                                    ffecom_2 (MINUS_EXPR,
6721                                              ffecom_f2c_ftnlen_type_node,
6722                                              length,
6723                                              start_tree));
6724               }
6725             else
6726               {
6727                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
6728                                     ffecom_expr (end));
6729
6730                 if (end_tree == error_mark_node)
6731                   {
6732                     length = error_mark_node;
6733                     break;
6734                   }
6735
6736                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6737                                    ffecom_f2c_ftnlen_one_node,
6738                                    ffecom_2 (MINUS_EXPR,
6739                                              ffecom_f2c_ftnlen_type_node,
6740                                              end_tree, start_tree));
6741               }
6742           }
6743       }
6744       break;
6745
6746     case FFEBLD_opCONCATENATE:
6747       length
6748         = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6749                     ffecom_intrinsic_len_ (ffebld_left (expr)),
6750                     ffecom_intrinsic_len_ (ffebld_right (expr)));
6751       break;
6752
6753     case FFEBLD_opFUNCREF:
6754     case FFEBLD_opCONVERT:
6755       length = build_int_2 (ffebld_size (expr), 0);
6756       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6757       break;
6758
6759     default:
6760       assert ("bad op for single char arg expr" == NULL);
6761       length = ffecom_f2c_ftnlen_zero_node;
6762       break;
6763     }
6764
6765   assert (length != NULL_TREE);
6766
6767   return length;
6768 }
6769
6770 #endif
6771 /* Handle CHARACTER assignments.
6772
6773    Generates code to do the assignment.  Used by ordinary assignment
6774    statement handler ffecom_let_stmt and by statement-function
6775    handler to generate code for a statement function.  */
6776
6777 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6778 static void
6779 ffecom_let_char_ (tree dest_tree, tree dest_length,
6780                   ffetargetCharacterSize dest_size, ffebld source)
6781 {
6782   ffecomConcatList_ catlist;
6783   tree source_length;
6784   tree source_tree;
6785   tree expr_tree;
6786
6787   if ((dest_tree == error_mark_node)
6788       || (dest_length == error_mark_node))
6789     return;
6790
6791   assert (dest_tree != NULL_TREE);
6792   assert (dest_length != NULL_TREE);
6793
6794   /* Source might be an opCONVERT, which just means it is a different size
6795      than the destination.  Since the underlying implementation here handles
6796      that (directly or via the s_copy or s_cat run-time-library functions),
6797      we don't need the "convenience" of an opCONVERT that tells us to
6798      truncate or blank-pad, particularly since the resulting implementation
6799      would probably be slower than otherwise. */
6800
6801   while (ffebld_op (source) == FFEBLD_opCONVERT)
6802     source = ffebld_left (source);
6803
6804   catlist = ffecom_concat_list_new_ (source, dest_size);
6805   switch (ffecom_concat_list_count_ (catlist))
6806     {
6807     case 0:                     /* Shouldn't happen, but in case it does... */
6808       ffecom_concat_list_kill_ (catlist);
6809       source_tree = null_pointer_node;
6810       source_length = ffecom_f2c_ftnlen_zero_node;
6811       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6812       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6813       TREE_CHAIN (TREE_CHAIN (expr_tree))
6814         = build_tree_list (NULL_TREE, dest_length);
6815       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6816         = build_tree_list (NULL_TREE, source_length);
6817
6818       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6819       TREE_SIDE_EFFECTS (expr_tree) = 1;
6820
6821       expand_expr_stmt (expr_tree);
6822
6823       return;
6824
6825     case 1:                     /* The (fairly) easy case. */
6826       ffecom_char_args_ (&source_tree, &source_length,
6827                          ffecom_concat_list_expr_ (catlist, 0));
6828       ffecom_concat_list_kill_ (catlist);
6829       assert (source_tree != NULL_TREE);
6830       assert (source_length != NULL_TREE);
6831
6832       if ((source_tree == error_mark_node)
6833           || (source_length == error_mark_node))
6834         return;
6835
6836       if (dest_size == 1)
6837         {
6838           dest_tree
6839             = ffecom_1 (INDIRECT_REF,
6840                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6841                                                       (dest_tree))),
6842                         dest_tree);
6843           dest_tree
6844             = ffecom_2 (ARRAY_REF,
6845                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6846                                                       (dest_tree))),
6847                         dest_tree,
6848                         integer_one_node);
6849           source_tree
6850             = ffecom_1 (INDIRECT_REF,
6851                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6852                                                       (source_tree))),
6853                         source_tree);
6854           source_tree
6855             = ffecom_2 (ARRAY_REF,
6856                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6857                                                       (source_tree))),
6858                         source_tree,
6859                         integer_one_node);
6860
6861           expr_tree = ffecom_modify (void_type_node, dest_tree, source_tree);
6862
6863           expand_expr_stmt (expr_tree);
6864
6865           return;
6866         }
6867
6868       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6869       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6870       TREE_CHAIN (TREE_CHAIN (expr_tree))
6871         = build_tree_list (NULL_TREE, dest_length);
6872       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6873         = build_tree_list (NULL_TREE, source_length);
6874
6875       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6876       TREE_SIDE_EFFECTS (expr_tree) = 1;
6877
6878       expand_expr_stmt (expr_tree);
6879
6880       return;
6881
6882     default:                    /* Must actually concatenate things. */
6883       break;
6884     }
6885
6886   /* Heavy-duty concatenation. */
6887
6888   {
6889     int count = ffecom_concat_list_count_ (catlist);
6890     int i;
6891     tree lengths;
6892     tree items;
6893     tree length_array;
6894     tree item_array;
6895     tree citem;
6896     tree clength;
6897
6898 #ifdef HOHO
6899     length_array
6900       = lengths
6901       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
6902                              FFETARGET_charactersizeNONE, count, TRUE);
6903     item_array = items = ffecom_push_tempvar (ffecom_f2c_address_type_node,
6904                                               FFETARGET_charactersizeNONE,
6905                                               count, TRUE);
6906 #else
6907     {
6908       tree hook;
6909
6910       hook = ffebld_nonter_hook (source);
6911       assert (hook);
6912       assert (TREE_CODE (hook) == TREE_VEC);
6913       assert (TREE_VEC_LENGTH (hook) == 2);
6914       length_array = lengths = TREE_VEC_ELT (hook, 0);
6915       item_array = items = TREE_VEC_ELT (hook, 1);
6916     }
6917 #endif
6918
6919     for (i = 0; i < count; ++i)
6920       {
6921         ffecom_char_args_ (&citem, &clength,
6922                            ffecom_concat_list_expr_ (catlist, i));
6923         if ((citem == error_mark_node)
6924             || (clength == error_mark_node))
6925           {
6926             ffecom_concat_list_kill_ (catlist);
6927             return;
6928           }
6929
6930         items
6931           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
6932                       ffecom_modify (void_type_node,
6933                                      ffecom_2 (ARRAY_REF,
6934                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
6935                                                item_array,
6936                                                build_int_2 (i, 0)),
6937                                      citem),
6938                       items);
6939         lengths
6940           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
6941                       ffecom_modify (void_type_node,
6942                                      ffecom_2 (ARRAY_REF,
6943                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
6944                                                length_array,
6945                                                build_int_2 (i, 0)),
6946                                      clength),
6947                       lengths);
6948       }
6949
6950     expr_tree = build_tree_list (NULL_TREE, dest_tree);
6951     TREE_CHAIN (expr_tree)
6952       = build_tree_list (NULL_TREE,
6953                          ffecom_1 (ADDR_EXPR,
6954                                    build_pointer_type (TREE_TYPE (items)),
6955                                    items));
6956     TREE_CHAIN (TREE_CHAIN (expr_tree))
6957       = build_tree_list (NULL_TREE,
6958                          ffecom_1 (ADDR_EXPR,
6959                                    build_pointer_type (TREE_TYPE (lengths)),
6960                                    lengths));
6961     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6962       = build_tree_list
6963         (NULL_TREE,
6964          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
6965                    convert (ffecom_f2c_ftnlen_type_node,
6966                             build_int_2 (count, 0))));
6967     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))))
6968       = build_tree_list (NULL_TREE, dest_length);
6969
6970     expr_tree = ffecom_call_gfrt (FFECOM_gfrtCAT, expr_tree, NULL_TREE);
6971     TREE_SIDE_EFFECTS (expr_tree) = 1;
6972
6973     expand_expr_stmt (expr_tree);
6974   }
6975
6976   ffecom_concat_list_kill_ (catlist);
6977 }
6978
6979 #endif
6980 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
6981
6982    ffecomGfrt ix;
6983    ffecom_make_gfrt_(ix);
6984
6985    Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
6986    for the indicated run-time routine (ix).  */
6987
6988 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6989 static void
6990 ffecom_make_gfrt_ (ffecomGfrt ix)
6991 {
6992   tree t;
6993   tree ttype;
6994
6995   switch (ffecom_gfrt_type_[ix])
6996     {
6997     case FFECOM_rttypeVOID_:
6998       ttype = void_type_node;
6999       break;
7000
7001     case FFECOM_rttypeVOIDSTAR_:
7002       ttype = TREE_TYPE (null_pointer_node);    /* `void *'. */
7003       break;
7004
7005     case FFECOM_rttypeFTNINT_:
7006       ttype = ffecom_f2c_ftnint_type_node;
7007       break;
7008
7009     case FFECOM_rttypeINTEGER_:
7010       ttype = ffecom_f2c_integer_type_node;
7011       break;
7012
7013     case FFECOM_rttypeLONGINT_:
7014       ttype = ffecom_f2c_longint_type_node;
7015       break;
7016
7017     case FFECOM_rttypeLOGICAL_:
7018       ttype = ffecom_f2c_logical_type_node;
7019       break;
7020
7021     case FFECOM_rttypeREAL_F2C_:
7022       ttype = double_type_node;
7023       break;
7024
7025     case FFECOM_rttypeREAL_GNU_:
7026       ttype = float_type_node;
7027       break;
7028
7029     case FFECOM_rttypeCOMPLEX_F2C_:
7030       ttype = void_type_node;
7031       break;
7032
7033     case FFECOM_rttypeCOMPLEX_GNU_:
7034       ttype = ffecom_f2c_complex_type_node;
7035       break;
7036
7037     case FFECOM_rttypeDOUBLE_:
7038       ttype = double_type_node;
7039       break;
7040
7041     case FFECOM_rttypeDOUBLEREAL_:
7042       ttype = ffecom_f2c_doublereal_type_node;
7043       break;
7044
7045     case FFECOM_rttypeDBLCMPLX_F2C_:
7046       ttype = void_type_node;
7047       break;
7048
7049     case FFECOM_rttypeDBLCMPLX_GNU_:
7050       ttype = ffecom_f2c_doublecomplex_type_node;
7051       break;
7052
7053     case FFECOM_rttypeCHARACTER_:
7054       ttype = void_type_node;
7055       break;
7056
7057     default:
7058       ttype = NULL;
7059       assert ("bad rttype" == NULL);
7060       break;
7061     }
7062
7063   ttype = build_function_type (ttype, NULL_TREE);
7064   t = build_decl (FUNCTION_DECL,
7065                   get_identifier (ffecom_gfrt_name_[ix]),
7066                   ttype);
7067   DECL_EXTERNAL (t) = 1;
7068   TREE_PUBLIC (t) = 1;
7069   TREE_THIS_VOLATILE (t) = ffecom_gfrt_volatile_[ix] ? 1 : 0;
7070
7071   t = start_decl (t, TRUE);
7072
7073   finish_decl (t, NULL_TREE, TRUE);
7074
7075   ffecom_gfrt_[ix] = t;
7076 }
7077
7078 #endif
7079 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group.  */
7080
7081 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7082 static void
7083 ffecom_member_phase1_ (ffestorag mst UNUSED, ffestorag st)
7084 {
7085   ffesymbol s = ffestorag_symbol (st);
7086
7087   if (ffesymbol_namelisted (s))
7088     ffecom_member_namelisted_ = TRUE;
7089 }
7090
7091 #endif
7092 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group.  Declare
7093    the member so debugger will see it.  Otherwise nobody should be
7094    referencing the member.  */
7095
7096 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7097 static void
7098 ffecom_member_phase2_ (ffestorag mst, ffestorag st)
7099 {
7100   ffesymbol s;
7101   tree t;
7102   tree mt;
7103   tree type;
7104
7105   if ((mst == NULL)
7106       || ((mt = ffestorag_hook (mst)) == NULL)
7107       || (mt == error_mark_node))
7108     return;
7109
7110   if ((st == NULL)
7111       || ((s = ffestorag_symbol (st)) == NULL))
7112     return;
7113
7114   type = ffecom_type_localvar_ (s,
7115                                 ffesymbol_basictype (s),
7116                                 ffesymbol_kindtype (s));
7117   if (type == error_mark_node)
7118     return;
7119
7120   t = build_decl (VAR_DECL,
7121                   ffecom_get_identifier_ (ffesymbol_text (s)),
7122                   type);
7123
7124   TREE_STATIC (t) = TREE_STATIC (mt);
7125   DECL_INITIAL (t) = NULL_TREE;
7126   TREE_ASM_WRITTEN (t) = 1;
7127
7128   DECL_RTL (t)
7129     = gen_rtx (MEM, TYPE_MODE (type),
7130                plus_constant (XEXP (DECL_RTL (mt), 0),
7131                               ffestorag_modulo (mst)
7132                               + ffestorag_offset (st)
7133                               - ffestorag_offset (mst)));
7134
7135   t = start_decl (t, FALSE);
7136
7137   finish_decl (t, NULL_TREE, FALSE);
7138 }
7139
7140 #endif
7141 /* Prepare source expression for assignment into a destination perhaps known
7142    to be of a specific size.  */
7143
7144 static void
7145 ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size, ffebld source)
7146 {
7147   ffecomConcatList_ catlist;
7148   int count;
7149   int i;
7150   tree ltmp;
7151   tree itmp;
7152   tree tempvar = NULL_TREE;
7153
7154   while (ffebld_op (source) == FFEBLD_opCONVERT)
7155     source = ffebld_left (source);
7156
7157   catlist = ffecom_concat_list_new_ (source, dest_size);
7158   count = ffecom_concat_list_count_ (catlist);
7159
7160   if (count >= 2)
7161     {
7162       ltmp
7163         = ffecom_make_tempvar ("let_char_len", ffecom_f2c_ftnlen_type_node,
7164                                FFETARGET_charactersizeNONE, count);
7165       itmp
7166         = ffecom_make_tempvar ("let_char_item", ffecom_f2c_address_type_node,
7167                                FFETARGET_charactersizeNONE, count);
7168
7169       tempvar = make_tree_vec (2);
7170       TREE_VEC_ELT (tempvar, 0) = ltmp;
7171       TREE_VEC_ELT (tempvar, 1) = itmp;
7172     }
7173
7174   for (i = 0; i < count; ++i)
7175     ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist, i));
7176
7177   ffecom_concat_list_kill_ (catlist);
7178
7179   if (tempvar)
7180     {
7181       ffebld_nonter_set_hook (source, tempvar);
7182       current_binding_level->prep_state = 1;
7183     }
7184 }
7185
7186 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
7187
7188    Ignores STAR (alternate-return) dummies.  All other get exec-transitioned
7189    (which generates their trees) and then their trees get push_parm_decl'd.
7190
7191    The second arg is TRUE if the dummies are for a statement function, in
7192    which case lengths are not pushed for character arguments (since they are
7193    always known by both the caller and the callee, though the code allows
7194    for someday permitting CHAR*(*) stmtfunc dummies).  */
7195
7196 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7197 static void
7198 ffecom_push_dummy_decls_ (ffebld dummy_list, bool stmtfunc)
7199 {
7200   ffebld dummy;
7201   ffebld dumlist;
7202   ffesymbol s;
7203   tree parm;
7204
7205   ffecom_transform_only_dummies_ = TRUE;
7206
7207   /* First push the parms corresponding to actual dummy "contents".  */
7208
7209   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7210     {
7211       dummy = ffebld_head (dumlist);
7212       switch (ffebld_op (dummy))
7213         {
7214         case FFEBLD_opSTAR:
7215         case FFEBLD_opANY:
7216           continue;             /* Forget alternate returns. */
7217
7218         default:
7219           break;
7220         }
7221       assert (ffebld_op (dummy) == FFEBLD_opSYMTER);
7222       s = ffebld_symter (dummy);
7223       parm = ffesymbol_hook (s).decl_tree;
7224       if (parm == NULL_TREE)
7225         {
7226           s = ffecom_sym_transform_ (s);
7227           parm = ffesymbol_hook (s).decl_tree;
7228           assert (parm != NULL_TREE);
7229         }
7230       if (parm != error_mark_node)
7231         push_parm_decl (parm);
7232     }
7233
7234   /* Then, for CHARACTER dummies, push the parms giving their lengths.  */
7235
7236   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7237     {
7238       dummy = ffebld_head (dumlist);
7239       switch (ffebld_op (dummy))
7240         {
7241         case FFEBLD_opSTAR:
7242         case FFEBLD_opANY:
7243           continue;             /* Forget alternate returns, they mean
7244                                    NOTHING! */
7245
7246         default:
7247           break;
7248         }
7249       s = ffebld_symter (dummy);
7250       if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
7251         continue;               /* Only looking for CHARACTER arguments. */
7252       if (stmtfunc && (ffesymbol_size (s) != FFETARGET_charactersizeNONE))
7253         continue;               /* Stmtfunc arg with known size needs no
7254                                    length param. */
7255       if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
7256         continue;               /* Only looking for variables and arrays. */
7257       parm = ffesymbol_hook (s).length_tree;
7258       assert (parm != NULL_TREE);
7259       if (parm != error_mark_node)
7260         push_parm_decl (parm);
7261     }
7262
7263   ffecom_transform_only_dummies_ = FALSE;
7264 }
7265
7266 #endif
7267 /* ffecom_start_progunit_ -- Beginning of program unit
7268
7269    Does GNU back end stuff necessary to teach it about the start of its
7270    equivalent of a Fortran program unit.  */
7271
7272 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7273 static void
7274 ffecom_start_progunit_ ()
7275 {
7276   ffesymbol fn = ffecom_primary_entry_;
7277   ffebld arglist;
7278   tree id;                      /* Identifier (name) of function. */
7279   tree type;                    /* Type of function. */
7280   tree result;                  /* Result of function. */
7281   ffeinfoBasictype bt;
7282   ffeinfoKindtype kt;
7283   ffeglobal g;
7284   ffeglobalType gt;
7285   ffeglobalType egt = FFEGLOBAL_type;
7286   bool charfunc;
7287   bool cmplxfunc;
7288   bool altentries = (ffecom_num_entrypoints_ != 0);
7289   bool multi
7290   = altentries
7291   && (ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
7292   && (ffecom_master_bt_ == FFEINFO_basictypeNONE);
7293   bool main_program = FALSE;
7294   int old_lineno = lineno;
7295   char *old_input_filename = input_filename;
7296   int yes;
7297
7298   assert (fn != NULL);
7299   assert (ffesymbol_hook (fn).decl_tree == NULL_TREE);
7300
7301   input_filename = ffesymbol_where_filename (fn);
7302   lineno = ffesymbol_where_filelinenum (fn);
7303
7304   /* c-parse.y indeed does call suspend_momentary and not only ignores the
7305      return value, but also never calls resume_momentary, when starting an
7306      outer function (see "fndef:", "setspecs:", and so on).  So g77 does the
7307      same thing.  It shouldn't be a problem since start_function calls
7308      temporary_allocation, but it might be necessary.  If it causes a problem
7309      here, then maybe there's a bug lurking in gcc.  NOTE: This identical
7310      comment appears twice in thist file.  */
7311
7312   suspend_momentary ();
7313
7314   switch (ffecom_primary_entry_kind_)
7315     {
7316     case FFEINFO_kindPROGRAM:
7317       main_program = TRUE;
7318       gt = FFEGLOBAL_typeMAIN;
7319       bt = FFEINFO_basictypeNONE;
7320       kt = FFEINFO_kindtypeNONE;
7321       type = ffecom_tree_fun_type_void;
7322       charfunc = FALSE;
7323       cmplxfunc = FALSE;
7324       break;
7325
7326     case FFEINFO_kindBLOCKDATA:
7327       gt = FFEGLOBAL_typeBDATA;
7328       bt = FFEINFO_basictypeNONE;
7329       kt = FFEINFO_kindtypeNONE;
7330       type = ffecom_tree_fun_type_void;
7331       charfunc = FALSE;
7332       cmplxfunc = FALSE;
7333       break;
7334
7335     case FFEINFO_kindFUNCTION:
7336       gt = FFEGLOBAL_typeFUNC;
7337       egt = FFEGLOBAL_typeEXT;
7338       bt = ffesymbol_basictype (fn);
7339       kt = ffesymbol_kindtype (fn);
7340       if (bt == FFEINFO_basictypeNONE)
7341         {
7342           ffeimplic_establish_symbol (fn);
7343           if (ffesymbol_funcresult (fn) != NULL)
7344             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
7345           bt = ffesymbol_basictype (fn);
7346           kt = ffesymbol_kindtype (fn);
7347         }
7348
7349       if (multi)
7350         charfunc = cmplxfunc = FALSE;
7351       else if (bt == FFEINFO_basictypeCHARACTER)
7352         charfunc = TRUE, cmplxfunc = FALSE;
7353       else if ((bt == FFEINFO_basictypeCOMPLEX)
7354                && ffesymbol_is_f2c (fn)
7355                && !altentries)
7356         charfunc = FALSE, cmplxfunc = TRUE;
7357       else
7358         charfunc = cmplxfunc = FALSE;
7359
7360       if (multi || charfunc)
7361         type = ffecom_tree_fun_type_void;
7362       else if (ffesymbol_is_f2c (fn) && !altentries)
7363         type = ffecom_tree_fun_type[bt][kt];
7364       else
7365         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
7366
7367       if ((type == NULL_TREE)
7368           || (TREE_TYPE (type) == NULL_TREE))
7369         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
7370       break;
7371
7372     case FFEINFO_kindSUBROUTINE:
7373       gt = FFEGLOBAL_typeSUBR;
7374       egt = FFEGLOBAL_typeEXT;
7375       bt = FFEINFO_basictypeNONE;
7376       kt = FFEINFO_kindtypeNONE;
7377       if (ffecom_is_altreturning_)
7378         type = ffecom_tree_subr_type;
7379       else
7380         type = ffecom_tree_fun_type_void;
7381       charfunc = FALSE;
7382       cmplxfunc = FALSE;
7383       break;
7384
7385     default:
7386       assert ("say what??" == NULL);
7387       /* Fall through. */
7388     case FFEINFO_kindANY:
7389       gt = FFEGLOBAL_typeANY;
7390       bt = FFEINFO_basictypeNONE;
7391       kt = FFEINFO_kindtypeNONE;
7392       type = error_mark_node;
7393       charfunc = FALSE;
7394       cmplxfunc = FALSE;
7395       break;
7396     }
7397
7398   if (altentries)
7399     {
7400       id = ffecom_get_invented_identifier ("__g77_masterfun_%s",
7401                                            ffesymbol_text (fn));
7402     }
7403 #if FFETARGET_isENFORCED_MAIN
7404   else if (main_program)
7405     id = get_identifier (FFETARGET_nameENFORCED_MAIN_NAME);
7406 #endif
7407   else
7408     id = ffecom_get_external_identifier_ (fn);
7409
7410   start_function (id,
7411                   type,
7412                   0,            /* nested/inline */
7413                   !altentries); /* TREE_PUBLIC */
7414
7415   TREE_USED (current_function_decl) = 1;        /* Avoid spurious warning if altentries. */
7416
7417   if (!altentries
7418       && ((g = ffesymbol_global (fn)) != NULL)
7419       && ((ffeglobal_type (g) == gt)
7420           || (ffeglobal_type (g) == egt)))
7421     {
7422       ffeglobal_set_hook (g, current_function_decl);
7423     }
7424
7425   yes = suspend_momentary ();
7426
7427   /* Arg handling needs exec-transitioned ffesymbols to work with.  But
7428      exec-transitioning needs current_function_decl to be filled in.  So we
7429      do these things in two phases. */
7430
7431   if (altentries)
7432     {                           /* 1st arg identifies which entrypoint. */
7433       ffecom_which_entrypoint_decl_
7434         = build_decl (PARM_DECL,
7435                       ffecom_get_invented_identifier ("__g77_%s",
7436                                                       "which_entrypoint"),
7437                       integer_type_node);
7438       push_parm_decl (ffecom_which_entrypoint_decl_);
7439     }
7440
7441   if (charfunc
7442       || cmplxfunc
7443       || multi)
7444     {                           /* Arg for result (return value). */
7445       tree type;
7446       tree length;
7447
7448       if (charfunc)
7449         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
7450       else if (cmplxfunc)
7451         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
7452       else
7453         type = ffecom_multi_type_node_;
7454
7455       result = ffecom_get_invented_identifier ("__g77_%s", "result");
7456
7457       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
7458
7459       if (charfunc)
7460         length = ffecom_char_enhance_arg_ (&type, fn);
7461       else
7462         length = NULL_TREE;     /* Not ref'd if !charfunc. */
7463
7464       type = build_pointer_type (type);
7465       result = build_decl (PARM_DECL, result, type);
7466
7467       push_parm_decl (result);
7468       if (multi)
7469         ffecom_multi_retval_ = result;
7470       else
7471         ffecom_func_result_ = result;
7472
7473       if (charfunc)
7474         {
7475           push_parm_decl (length);
7476           ffecom_func_length_ = length;
7477         }
7478     }
7479
7480   if (ffecom_primary_entry_is_proc_)
7481     {
7482       if (altentries)
7483         arglist = ffecom_master_arglist_;
7484       else
7485         arglist = ffesymbol_dummyargs (fn);
7486       ffecom_push_dummy_decls_ (arglist, FALSE);
7487     }
7488
7489   resume_momentary (yes);
7490
7491   if (TREE_CODE (current_function_decl) != ERROR_MARK)
7492     store_parm_decls (main_program ? 1 : 0);
7493
7494   ffecom_start_compstmt ();
7495   /* Disallow temp vars at this level.  */
7496   current_binding_level->prep_state = 2;
7497
7498   lineno = old_lineno;
7499   input_filename = old_input_filename;
7500
7501   /* This handles any symbols still untransformed, in case -g specified.
7502      This used to be done in ffecom_finish_progunit, but it turns out to
7503      be necessary to do it here so that statement functions are
7504      expanded before code.  But don't bother for BLOCK DATA.  */
7505
7506   if (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
7507     ffesymbol_drive (ffecom_finish_symbol_transform_);
7508 }
7509
7510 #endif
7511 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
7512
7513    ffesymbol s;
7514    ffecom_sym_transform_(s);
7515
7516    The ffesymbol_hook info for s is updated with appropriate backend info
7517    on the symbol.  */
7518
7519 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7520 static ffesymbol
7521 ffecom_sym_transform_ (ffesymbol s)
7522 {
7523   tree t;                       /* Transformed thingy. */
7524   tree tlen;                    /* Length if CHAR*(*). */
7525   bool addr;                    /* Is t the address of the thingy? */
7526   ffeinfoBasictype bt;
7527   ffeinfoKindtype kt;
7528   ffeglobal g;
7529   int yes;
7530   int old_lineno = lineno;
7531   char *old_input_filename = input_filename;
7532
7533   /* Must ensure special ASSIGN variables are declared at top of outermost
7534      block, else they'll end up in the innermost block when their first
7535      ASSIGN is seen, which leaves them out of scope when they're the
7536      subject of a GOTO or I/O statement.
7537
7538      We make this variable even if -fugly-assign.  Just let it go unused,
7539      in case it turns out there are cases where we really want to use this
7540      variable anyway (e.g. ASSIGN to INTEGER*2 variable).  */
7541
7542   if (! ffecom_transform_only_dummies_
7543       && ffesymbol_assigned (s)
7544       && ! ffesymbol_hook (s).assign_tree)
7545     s = ffecom_sym_transform_assign_ (s);
7546
7547   if (ffesymbol_sfdummyparent (s) == NULL)
7548     {
7549       input_filename = ffesymbol_where_filename (s);
7550       lineno = ffesymbol_where_filelinenum (s);
7551     }
7552   else
7553     {
7554       ffesymbol sf = ffesymbol_sfdummyparent (s);
7555
7556       input_filename = ffesymbol_where_filename (sf);
7557       lineno = ffesymbol_where_filelinenum (sf);
7558     }
7559
7560   bt = ffeinfo_basictype (ffebld_info (s));
7561   kt = ffeinfo_kindtype (ffebld_info (s));
7562
7563   t = NULL_TREE;
7564   tlen = NULL_TREE;
7565   addr = FALSE;
7566
7567   switch (ffesymbol_kind (s))
7568     {
7569     case FFEINFO_kindNONE:
7570       switch (ffesymbol_where (s))
7571         {
7572         case FFEINFO_whereDUMMY:        /* Subroutine or function. */
7573           assert (ffecom_transform_only_dummies_);
7574
7575           /* Before 0.4, this could be ENTITY/DUMMY, but see
7576              ffestu_sym_end_transition -- no longer true (in particular, if
7577              it could be an ENTITY, it _will_ be made one, so that
7578              possibility won't come through here).  So we never make length
7579              arg for CHARACTER type.  */
7580
7581           t = build_decl (PARM_DECL,
7582                           ffecom_get_identifier_ (ffesymbol_text (s)),
7583                           ffecom_tree_ptr_to_subr_type);
7584 #if BUILT_FOR_270
7585           DECL_ARTIFICIAL (t) = 1;
7586 #endif
7587           addr = TRUE;
7588           break;
7589
7590         case FFEINFO_whereGLOBAL:       /* Subroutine or function. */
7591           assert (!ffecom_transform_only_dummies_);
7592
7593           if (((g = ffesymbol_global (s)) != NULL)
7594               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7595                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7596                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
7597               && (ffeglobal_hook (g) != NULL_TREE)
7598               && ffe_is_globals ())
7599             {
7600               t = ffeglobal_hook (g);
7601               break;
7602             }
7603
7604           t = build_decl (FUNCTION_DECL,
7605                           ffecom_get_external_identifier_ (s),
7606                           ffecom_tree_subr_type);       /* Assume subr. */
7607           DECL_EXTERNAL (t) = 1;
7608           TREE_PUBLIC (t) = 1;
7609
7610           t = start_decl (t, FALSE);
7611           finish_decl (t, NULL_TREE, FALSE);
7612
7613           if ((g != NULL)
7614               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7615                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7616                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
7617             ffeglobal_set_hook (g, t);
7618
7619           ffecom_save_tree_forever (t);
7620
7621           break;
7622
7623         default:
7624           assert ("NONE where unexpected" == NULL);
7625           /* Fall through. */
7626         case FFEINFO_whereANY:
7627           break;
7628         }
7629       break;
7630
7631     case FFEINFO_kindENTITY:
7632       switch (ffeinfo_where (ffesymbol_info (s)))
7633         {
7634
7635         case FFEINFO_whereCONSTANT:
7636           /* ~~Debugging info needed? */
7637           assert (!ffecom_transform_only_dummies_);
7638           t = error_mark_node;  /* Shouldn't ever see this in expr. */
7639           break;
7640
7641         case FFEINFO_whereLOCAL:
7642           assert (!ffecom_transform_only_dummies_);
7643
7644           {
7645             ffestorag st = ffesymbol_storage (s);
7646             tree type;
7647
7648             if ((st != NULL)
7649                 && (ffestorag_size (st) == 0))
7650               {
7651                 t = error_mark_node;
7652                 break;
7653               }
7654
7655             yes = suspend_momentary ();
7656             type = ffecom_type_localvar_ (s, bt, kt);
7657             resume_momentary (yes);
7658
7659             if (type == error_mark_node)
7660               {
7661                 t = error_mark_node;
7662                 break;
7663               }
7664
7665             if ((st != NULL)
7666                 && (ffestorag_parent (st) != NULL))
7667               {                 /* Child of EQUIVALENCE parent. */
7668                 ffestorag est;
7669                 tree et;
7670                 int yes;
7671                 ffetargetOffset offset;
7672
7673                 est = ffestorag_parent (st);
7674                 ffecom_transform_equiv_ (est);
7675
7676                 et = ffestorag_hook (est);
7677                 assert (et != NULL_TREE);
7678
7679                 if (! TREE_STATIC (et))
7680                   put_var_into_stack (et);
7681
7682                 yes = suspend_momentary ();
7683
7684                 offset = ffestorag_modulo (est)
7685                   + ffestorag_offset (ffesymbol_storage (s))
7686                   - ffestorag_offset (est);
7687
7688                 ffecom_debug_kludge_ (et, "EQUIVALENCE", s, type, offset);
7689
7690                 /* (t_type *) (((char *) &et) + offset) */
7691
7692                 t = convert (string_type_node,  /* (char *) */
7693                              ffecom_1 (ADDR_EXPR,
7694                                        build_pointer_type (TREE_TYPE (et)),
7695                                        et));
7696                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
7697                               t,
7698                               build_int_2 (offset, 0));
7699                 t = convert (build_pointer_type (type),
7700                              t);
7701                 TREE_CONSTANT (t) = staticp (et);
7702
7703                 addr = TRUE;
7704
7705                 resume_momentary (yes);
7706               }
7707             else
7708               {
7709                 tree initexpr;
7710                 bool init = ffesymbol_is_init (s);
7711
7712                 yes = suspend_momentary ();
7713
7714                 t = build_decl (VAR_DECL,
7715                                 ffecom_get_identifier_ (ffesymbol_text (s)),
7716                                 type);
7717
7718                 if (init
7719                     || ffesymbol_namelisted (s)
7720 #ifdef FFECOM_sizeMAXSTACKITEM
7721                     || ((st != NULL)
7722                         && (ffestorag_size (st) > FFECOM_sizeMAXSTACKITEM))
7723 #endif
7724                     || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
7725                         && (ffecom_primary_entry_kind_
7726                             != FFEINFO_kindBLOCKDATA)
7727                         && (ffesymbol_is_save (s) || ffe_is_saveall ())))
7728                   TREE_STATIC (t) = !ffesymbol_attr (s, FFESYMBOL_attrADJUSTABLE);
7729                 else
7730                   TREE_STATIC (t) = 0;  /* No need to make static. */
7731
7732                 if (init || ffe_is_init_local_zero ())
7733                   DECL_INITIAL (t) = error_mark_node;
7734
7735                 /* Keep -Wunused from complaining about var if it
7736                    is used as sfunc arg or DATA implied-DO.  */
7737                 if (ffesymbol_attrs (s) & FFESYMBOL_attrsSFARG)
7738                   DECL_IN_SYSTEM_HEADER (t) = 1;
7739
7740                 t = start_decl (t, FALSE);
7741
7742                 if (init)
7743                   {
7744                     if (ffesymbol_init (s) != NULL)
7745                       initexpr = ffecom_expr (ffesymbol_init (s));
7746                     else
7747                       initexpr = ffecom_init_zero_ (t);
7748                   }
7749                 else if (ffe_is_init_local_zero ())
7750                   initexpr = ffecom_init_zero_ (t);
7751                 else
7752                   initexpr = NULL_TREE; /* Not ref'd if !init. */
7753
7754                 finish_decl (t, initexpr, FALSE);
7755
7756                 if (st != NULL && DECL_SIZE (t) != error_mark_node)
7757                   {
7758                     assert (TREE_CODE (DECL_SIZE_UNIT (t)) == INTEGER_CST);
7759                     assert (0 == compare_tree_int (DECL_SIZE_UNIT (t),
7760                                                    ffestorag_size (st)));
7761                   }
7762
7763                 resume_momentary (yes);
7764               }
7765           }
7766           break;
7767
7768         case FFEINFO_whereRESULT:
7769           assert (!ffecom_transform_only_dummies_);
7770
7771           if (bt == FFEINFO_basictypeCHARACTER)
7772             {                   /* Result is already in list of dummies, use
7773                                    it (& length). */
7774               t = ffecom_func_result_;
7775               tlen = ffecom_func_length_;
7776               addr = TRUE;
7777               break;
7778             }
7779           if ((ffecom_num_entrypoints_ == 0)
7780               && (bt == FFEINFO_basictypeCOMPLEX)
7781               && (ffesymbol_is_f2c (ffecom_primary_entry_)))
7782             {                   /* Result is already in list of dummies, use
7783                                    it. */
7784               t = ffecom_func_result_;
7785               addr = TRUE;
7786               break;
7787             }
7788           if (ffecom_func_result_ != NULL_TREE)
7789             {
7790               t = ffecom_func_result_;
7791               break;
7792             }
7793           if ((ffecom_num_entrypoints_ != 0)
7794               && (ffecom_master_bt_ == FFEINFO_basictypeNONE))
7795             {
7796               yes = suspend_momentary ();
7797
7798               assert (ffecom_multi_retval_ != NULL_TREE);
7799               t = ffecom_1 (INDIRECT_REF, ffecom_multi_type_node_,
7800                             ffecom_multi_retval_);
7801               t = ffecom_2 (COMPONENT_REF, ffecom_tree_type[bt][kt],
7802                             t, ffecom_multi_fields_[bt][kt]);
7803
7804               resume_momentary (yes);
7805               break;
7806             }
7807
7808           yes = suspend_momentary ();
7809
7810           t = build_decl (VAR_DECL,
7811                           ffecom_get_identifier_ (ffesymbol_text (s)),
7812                           ffecom_tree_type[bt][kt]);
7813           TREE_STATIC (t) = 0;  /* Put result on stack. */
7814           t = start_decl (t, FALSE);
7815           finish_decl (t, NULL_TREE, FALSE);
7816
7817           ffecom_func_result_ = t;
7818
7819           resume_momentary (yes);
7820           break;
7821
7822         case FFEINFO_whereDUMMY:
7823           {
7824             tree type;
7825             ffebld dl;
7826             ffebld dim;
7827             tree low;
7828             tree high;
7829             tree old_sizes;
7830             bool adjustable = FALSE;    /* Conditionally adjustable? */
7831
7832             type = ffecom_tree_type[bt][kt];
7833             if (ffesymbol_sfdummyparent (s) != NULL)
7834               {
7835                 if (current_function_decl == ffecom_outer_function_decl_)
7836                   {                     /* Exec transition before sfunc
7837                                            context; get it later. */
7838                     break;
7839                   }
7840                 t = ffecom_get_identifier_ (ffesymbol_text
7841                                             (ffesymbol_sfdummyparent (s)));
7842               }
7843             else
7844               t = ffecom_get_identifier_ (ffesymbol_text (s));
7845
7846             assert (ffecom_transform_only_dummies_);
7847
7848             old_sizes = get_pending_sizes ();
7849             put_pending_sizes (old_sizes);
7850
7851             if (bt == FFEINFO_basictypeCHARACTER)
7852               tlen = ffecom_char_enhance_arg_ (&type, s);
7853             type = ffecom_check_size_overflow_ (s, type, TRUE);
7854
7855             for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
7856               {
7857                 if (type == error_mark_node)
7858                   break;
7859
7860                 dim = ffebld_head (dl);
7861                 assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
7862                 if ((ffebld_left (dim) == NULL) || ffecom_doing_entry_)
7863                   low = ffecom_integer_one_node;
7864                 else
7865                   low = ffecom_expr (ffebld_left (dim));
7866                 assert (ffebld_right (dim) != NULL);
7867                 if ((ffebld_op (ffebld_right (dim)) == FFEBLD_opSTAR)
7868                     || ffecom_doing_entry_)
7869                   {
7870                     /* Used to just do high=low.  But for ffecom_tree_
7871                        canonize_ref_, it probably is important to correctly
7872                        assess the size.  E.g. given COMPLEX C(*),CFUNC and
7873                        C(2)=CFUNC(C), overlap can happen, while it can't
7874                        for, say, C(1)=CFUNC(C(2)).  */
7875                     /* Even more recently used to set to INT_MAX, but that
7876                        broke when some overflow checking went into the back
7877                        end.  Now we just leave the upper bound unspecified.  */
7878                     high = NULL;
7879                   }
7880                 else
7881                   high = ffecom_expr (ffebld_right (dim));
7882
7883                 /* Determine whether array is conditionally adjustable,
7884                    to decide whether back-end magic is needed.
7885
7886                    Normally the front end uses the back-end function
7887                    variable_size to wrap SAVE_EXPR's around expressions
7888                    affecting the size/shape of an array so that the
7889                    size/shape info doesn't change during execution
7890                    of the compiled code even though variables and
7891                    functions referenced in those expressions might.
7892
7893                    variable_size also makes sure those saved expressions
7894                    get evaluated immediately upon entry to the
7895                    compiled procedure -- the front end normally doesn't
7896                    have to worry about that.
7897
7898                    However, there is a problem with this that affects
7899                    g77's implementation of entry points, and that is
7900                    that it is _not_ true that each invocation of the
7901                    compiled procedure is permitted to evaluate
7902                    array size/shape info -- because it is possible
7903                    that, for some invocations, that info is invalid (in
7904                    which case it is "promised" -- i.e. a violation of
7905                    the Fortran standard -- that the compiled code
7906                    won't reference the array or its size/shape
7907                    during that particular invocation).
7908
7909                    To phrase this in C terms, consider this gcc function:
7910
7911                      void foo (int *n, float (*a)[*n])
7912                      {
7913                        // a is "pointer to array ...", fyi.
7914                      }
7915
7916                    Suppose that, for some invocations, it is permitted
7917                    for a caller of foo to do this:
7918
7919                        foo (NULL, NULL);
7920
7921                    Now the _written_ code for foo can take such a call
7922                    into account by either testing explicitly for whether
7923                    (a == NULL) || (n == NULL) -- presumably it is
7924                    not permitted to reference *a in various fashions
7925                    if (n == NULL) I suppose -- or it can avoid it by
7926                    looking at other info (other arguments, static/global
7927                    data, etc.).
7928
7929                    However, this won't work in gcc 2.5.8 because it'll
7930                    automatically emit the code to save the "*n"
7931                    expression, which'll yield a NULL dereference for
7932                    the "foo (NULL, NULL)" call, something the code
7933                    for foo cannot prevent.
7934
7935                    g77 definitely needs to avoid executing such
7936                    code anytime the pointer to the adjustable array
7937                    is NULL, because even if its bounds expressions
7938                    don't have any references to possible "absent"
7939                    variables like "*n" -- say all variable references
7940                    are to COMMON variables, i.e. global (though in C,
7941                    local static could actually make sense) -- the
7942                    expressions could yield other run-time problems
7943                    for allowably "dead" values in those variables.
7944
7945                    For example, let's consider a more complicated
7946                    version of foo:
7947
7948                      extern int i;
7949                      extern int j;
7950
7951                      void foo (float (*a)[i/j])
7952                      {
7953                        ...
7954                      }
7955
7956                    The above is (essentially) quite valid for Fortran
7957                    but, again, for a call like "foo (NULL);", it is
7958                    permitted for i and j to be undefined when the
7959                    call is made.  If j happened to be zero, for
7960                    example, emitting the code to evaluate "i/j"
7961                    could result in a run-time error.
7962
7963                    Offhand, though I don't have my F77 or F90
7964                    standards handy, it might even be valid for a
7965                    bounds expression to contain a function reference,
7966                    in which case I doubt it is permitted for an
7967                    implementation to invoke that function in the
7968                    Fortran case involved here (invocation of an
7969                    alternate ENTRY point that doesn't have the adjustable
7970                    array as one of its arguments).
7971
7972                    So, the code that the compiler would normally emit
7973                    to preevaluate the size/shape info for an
7974                    adjustable array _must not_ be executed at run time
7975                    in certain cases.  Specifically, for Fortran,
7976                    the case is when the pointer to the adjustable
7977                    array == NULL.  (For gnu-ish C, it might be nice
7978                    for the source code itself to specify an expression
7979                    that, if TRUE, inhibits execution of the code.  Or
7980                    reverse the sense for elegance.)
7981
7982                    (Note that g77 could use a different test than NULL,
7983                    actually, since it happens to always pass an
7984                    integer to the called function that specifies which
7985                    entry point is being invoked.  Hmm, this might
7986                    solve the next problem.)
7987
7988                    One way a user could, I suppose, write "foo" so
7989                    it works is to insert COND_EXPR's for the
7990                    size/shape info so the dangerous stuff isn't
7991                    actually done, as in:
7992
7993                      void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
7994                      {
7995                        ...
7996                      }
7997
7998                    The next problem is that the front end needs to
7999                    be able to tell the back end about the array's
8000                    decl _before_ it tells it about the conditional
8001                    expression to inhibit evaluation of size/shape info,
8002                    as shown above.
8003
8004                    To solve this, the front end needs to be able
8005                    to give the back end the expression to inhibit
8006                    generation of the preevaluation code _after_
8007                    it makes the decl for the adjustable array.
8008
8009                    Until then, the above example using the COND_EXPR
8010                    doesn't pass muster with gcc because the "(a == NULL)"
8011                    part has a reference to "a", which is still
8012                    undefined at that point.
8013
8014                    g77 will therefore use a different mechanism in the
8015                    meantime.  */
8016
8017                 if (!adjustable
8018                     && ((TREE_CODE (low) != INTEGER_CST)
8019                         || (high && TREE_CODE (high) != INTEGER_CST)))
8020                   adjustable = TRUE;
8021
8022 #if 0                           /* Old approach -- see below. */
8023                 if (TREE_CODE (low) != INTEGER_CST)
8024                   low = ffecom_3 (COND_EXPR, integer_type_node,
8025                                   ffecom_adjarray_passed_ (s),
8026                                   low,
8027                                   ffecom_integer_zero_node);
8028
8029                 if (high && TREE_CODE (high) != INTEGER_CST)
8030                   high = ffecom_3 (COND_EXPR, integer_type_node,
8031                                    ffecom_adjarray_passed_ (s),
8032                                    high,
8033                                    ffecom_integer_zero_node);
8034 #endif
8035
8036                 /* ~~~gcc/stor-layout.c (layout_type) should do this,
8037                    probably.  Fixes 950302-1.f.  */
8038
8039                 if (TREE_CODE (low) != INTEGER_CST)
8040                   low = variable_size (low);
8041
8042                 /* ~~~Similarly, this fixes dumb0.f.  The C front end
8043                    does this, which is why dumb0.c would work.  */
8044
8045                 if (high && TREE_CODE (high) != INTEGER_CST)
8046                   high = variable_size (high);
8047
8048                 type
8049                   = build_array_type
8050                     (type,
8051                      build_range_type (ffecom_integer_type_node,
8052                                        low, high));
8053                 type = ffecom_check_size_overflow_ (s, type, TRUE);
8054               }
8055
8056             if (type == error_mark_node)
8057               {
8058                 t = error_mark_node;
8059                 break;
8060               }
8061
8062             if ((ffesymbol_sfdummyparent (s) == NULL)
8063                  || (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
8064               {
8065                 type = build_pointer_type (type);
8066                 addr = TRUE;
8067               }
8068
8069             t = build_decl (PARM_DECL, t, type);
8070 #if BUILT_FOR_270
8071             DECL_ARTIFICIAL (t) = 1;
8072 #endif
8073
8074             /* If this arg is present in every entry point's list of
8075                dummy args, then we're done.  */
8076
8077             if (ffesymbol_numentries (s)
8078                 == (ffecom_num_entrypoints_ + 1))
8079               break;
8080
8081 #if 1
8082
8083             /* If variable_size in stor-layout has been called during
8084                the above, then get_pending_sizes should have the
8085                yet-to-be-evaluated saved expressions pending.
8086                Make the whole lot of them get emitted, conditionally
8087                on whether the array decl ("t" above) is not NULL.  */
8088
8089             {
8090               tree sizes = get_pending_sizes ();
8091               tree tem;
8092
8093               for (tem = sizes;
8094                    tem != old_sizes;
8095                    tem = TREE_CHAIN (tem))
8096                 {
8097                   tree temv = TREE_VALUE (tem);
8098
8099                   if (sizes == tem)
8100                     sizes = temv;
8101                   else
8102                     sizes
8103                       = ffecom_2 (COMPOUND_EXPR,
8104                                   TREE_TYPE (sizes),
8105                                   temv,
8106                                   sizes);
8107                 }
8108
8109               if (sizes != tem)
8110                 {
8111                   sizes
8112                     = ffecom_3 (COND_EXPR,
8113                                 TREE_TYPE (sizes),
8114                                 ffecom_2 (NE_EXPR,
8115                                           integer_type_node,
8116                                           t,
8117                                           null_pointer_node),
8118                                 sizes,
8119                                 convert (TREE_TYPE (sizes),
8120                                          integer_zero_node));
8121                   sizes = ffecom_save_tree (sizes);
8122
8123                   sizes
8124                     = tree_cons (NULL_TREE, sizes, tem);
8125                 }
8126
8127               if (sizes)
8128                 put_pending_sizes (sizes);
8129             }
8130
8131 #else
8132 #if 0
8133             if (adjustable
8134                 && (ffesymbol_numentries (s)
8135                     != ffecom_num_entrypoints_ + 1))
8136               DECL_SOMETHING (t)
8137                 = ffecom_2 (NE_EXPR, integer_type_node,
8138                             t,
8139                             null_pointer_node);
8140 #else
8141 #if 0
8142             if (adjustable
8143                 && (ffesymbol_numentries (s)
8144                     != ffecom_num_entrypoints_ + 1))
8145               {
8146                 ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED);
8147                 ffebad_here (0, ffesymbol_where_line (s),
8148                              ffesymbol_where_column (s));
8149                 ffebad_string (ffesymbol_text (s));
8150                 ffebad_finish ();
8151               }
8152 #endif
8153 #endif
8154 #endif
8155           }
8156           break;
8157
8158         case FFEINFO_whereCOMMON:
8159           {
8160             ffesymbol cs;
8161             ffeglobal cg;
8162             tree ct;
8163             ffestorag st = ffesymbol_storage (s);
8164             tree type;
8165             int yes;
8166
8167             cs = ffesymbol_common (s);  /* The COMMON area itself.  */
8168             if (st != NULL)     /* Else not laid out. */
8169               {
8170                 ffecom_transform_common_ (cs);
8171                 st = ffesymbol_storage (s);
8172               }
8173
8174             yes = suspend_momentary ();
8175
8176             type = ffecom_type_localvar_ (s, bt, kt);
8177
8178             cg = ffesymbol_global (cs); /* The global COMMON info.  */
8179             if ((cg == NULL)
8180                 || (ffeglobal_type (cg) != FFEGLOBAL_typeCOMMON))
8181               ct = NULL_TREE;
8182             else
8183               ct = ffeglobal_hook (cg); /* The common area's tree.  */
8184
8185             if ((ct == NULL_TREE)
8186                 || (st == NULL)
8187                 || (type == error_mark_node))
8188               t = error_mark_node;
8189             else
8190               {
8191                 ffetargetOffset offset;
8192                 ffestorag cst;
8193
8194                 cst = ffestorag_parent (st);
8195                 assert (cst == ffesymbol_storage (cs));
8196
8197                 offset = ffestorag_modulo (cst)
8198                   + ffestorag_offset (st)
8199                   - ffestorag_offset (cst);
8200
8201                 ffecom_debug_kludge_ (ct, "COMMON", s, type, offset);
8202
8203                 /* (t_type *) (((char *) &ct) + offset) */
8204
8205                 t = convert (string_type_node,  /* (char *) */
8206                              ffecom_1 (ADDR_EXPR,
8207                                        build_pointer_type (TREE_TYPE (ct)),
8208                                        ct));
8209                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
8210                               t,
8211                               build_int_2 (offset, 0));
8212                 t = convert (build_pointer_type (type),
8213                              t);
8214                 TREE_CONSTANT (t) = 1;
8215
8216                 addr = TRUE;
8217               }
8218
8219             resume_momentary (yes);
8220           }
8221           break;
8222
8223         case FFEINFO_whereIMMEDIATE:
8224         case FFEINFO_whereGLOBAL:
8225         case FFEINFO_whereFLEETING:
8226         case FFEINFO_whereFLEETING_CADDR:
8227         case FFEINFO_whereFLEETING_IADDR:
8228         case FFEINFO_whereINTRINSIC:
8229         case FFEINFO_whereCONSTANT_SUBOBJECT:
8230         default:
8231           assert ("ENTITY where unheard of" == NULL);
8232           /* Fall through. */
8233         case FFEINFO_whereANY:
8234           t = error_mark_node;
8235           break;
8236         }
8237       break;
8238
8239     case FFEINFO_kindFUNCTION:
8240       switch (ffeinfo_where (ffesymbol_info (s)))
8241         {
8242         case FFEINFO_whereLOCAL:        /* Me. */
8243           assert (!ffecom_transform_only_dummies_);
8244           t = current_function_decl;
8245           break;
8246
8247         case FFEINFO_whereGLOBAL:
8248           assert (!ffecom_transform_only_dummies_);
8249
8250           if (((g = ffesymbol_global (s)) != NULL)
8251               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8252                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8253               && (ffeglobal_hook (g) != NULL_TREE)
8254               && ffe_is_globals ())
8255             {
8256               t = ffeglobal_hook (g);
8257               break;
8258             }
8259
8260           if (ffesymbol_is_f2c (s)
8261               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8262             t = ffecom_tree_fun_type[bt][kt];
8263           else
8264             t = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
8265
8266           t = build_decl (FUNCTION_DECL,
8267                           ffecom_get_external_identifier_ (s),
8268                           t);
8269           DECL_EXTERNAL (t) = 1;
8270           TREE_PUBLIC (t) = 1;
8271
8272           t = start_decl (t, FALSE);
8273           finish_decl (t, NULL_TREE, FALSE);
8274
8275           if ((g != NULL)
8276               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8277                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8278             ffeglobal_set_hook (g, t);
8279
8280           ffecom_save_tree_forever (t);
8281
8282           break;
8283
8284         case FFEINFO_whereDUMMY:
8285           assert (ffecom_transform_only_dummies_);
8286
8287           if (ffesymbol_is_f2c (s)
8288               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8289             t = ffecom_tree_ptr_to_fun_type[bt][kt];
8290           else
8291             t = build_pointer_type
8292               (build_function_type (ffecom_tree_type[bt][kt], NULL_TREE));
8293
8294           t = build_decl (PARM_DECL,
8295                           ffecom_get_identifier_ (ffesymbol_text (s)),
8296                           t);
8297 #if BUILT_FOR_270
8298           DECL_ARTIFICIAL (t) = 1;
8299 #endif
8300           addr = TRUE;
8301           break;
8302
8303         case FFEINFO_whereCONSTANT:     /* Statement function. */
8304           assert (!ffecom_transform_only_dummies_);
8305           t = ffecom_gen_sfuncdef_ (s, bt, kt);
8306           break;
8307
8308         case FFEINFO_whereINTRINSIC:
8309           assert (!ffecom_transform_only_dummies_);
8310           break;                /* Let actual references generate their
8311                                    decls. */
8312
8313         default:
8314           assert ("FUNCTION where unheard of" == NULL);
8315           /* Fall through. */
8316         case FFEINFO_whereANY:
8317           t = error_mark_node;
8318           break;
8319         }
8320       break;
8321
8322     case FFEINFO_kindSUBROUTINE:
8323       switch (ffeinfo_where (ffesymbol_info (s)))
8324         {
8325         case FFEINFO_whereLOCAL:        /* Me. */
8326           assert (!ffecom_transform_only_dummies_);
8327           t = current_function_decl;
8328           break;
8329
8330         case FFEINFO_whereGLOBAL:
8331           assert (!ffecom_transform_only_dummies_);
8332
8333           if (((g = ffesymbol_global (s)) != NULL)
8334               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8335                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8336               && (ffeglobal_hook (g) != NULL_TREE)
8337               && ffe_is_globals ())
8338             {
8339               t = ffeglobal_hook (g);
8340               break;
8341             }
8342
8343           t = build_decl (FUNCTION_DECL,
8344                           ffecom_get_external_identifier_ (s),
8345                           ffecom_tree_subr_type);
8346           DECL_EXTERNAL (t) = 1;
8347           TREE_PUBLIC (t) = 1;
8348
8349           t = start_decl (t, FALSE);
8350           finish_decl (t, NULL_TREE, FALSE);
8351
8352           if ((g != NULL)
8353               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8354                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8355             ffeglobal_set_hook (g, t);
8356
8357           ffecom_save_tree_forever (t);
8358
8359           break;
8360
8361         case FFEINFO_whereDUMMY:
8362           assert (ffecom_transform_only_dummies_);
8363
8364           t = build_decl (PARM_DECL,
8365                           ffecom_get_identifier_ (ffesymbol_text (s)),
8366                           ffecom_tree_ptr_to_subr_type);
8367 #if BUILT_FOR_270
8368           DECL_ARTIFICIAL (t) = 1;
8369 #endif
8370           addr = TRUE;
8371           break;
8372
8373         case FFEINFO_whereINTRINSIC:
8374           assert (!ffecom_transform_only_dummies_);
8375           break;                /* Let actual references generate their
8376                                    decls. */
8377
8378         default:
8379           assert ("SUBROUTINE where unheard of" == NULL);
8380           /* Fall through. */
8381         case FFEINFO_whereANY:
8382           t = error_mark_node;
8383           break;
8384         }
8385       break;
8386
8387     case FFEINFO_kindPROGRAM:
8388       switch (ffeinfo_where (ffesymbol_info (s)))
8389         {
8390         case FFEINFO_whereLOCAL:        /* Me. */
8391           assert (!ffecom_transform_only_dummies_);
8392           t = current_function_decl;
8393           break;
8394
8395         case FFEINFO_whereCOMMON:
8396         case FFEINFO_whereDUMMY:
8397         case FFEINFO_whereGLOBAL:
8398         case FFEINFO_whereRESULT:
8399         case FFEINFO_whereFLEETING:
8400         case FFEINFO_whereFLEETING_CADDR:
8401         case FFEINFO_whereFLEETING_IADDR:
8402         case FFEINFO_whereIMMEDIATE:
8403         case FFEINFO_whereINTRINSIC:
8404         case FFEINFO_whereCONSTANT:
8405         case FFEINFO_whereCONSTANT_SUBOBJECT:
8406         default:
8407           assert ("PROGRAM where unheard of" == NULL);
8408           /* Fall through. */
8409         case FFEINFO_whereANY:
8410           t = error_mark_node;
8411           break;
8412         }
8413       break;
8414
8415     case FFEINFO_kindBLOCKDATA:
8416       switch (ffeinfo_where (ffesymbol_info (s)))
8417         {
8418         case FFEINFO_whereLOCAL:        /* Me. */
8419           assert (!ffecom_transform_only_dummies_);
8420           t = current_function_decl;
8421           break;
8422
8423         case FFEINFO_whereGLOBAL:
8424           assert (!ffecom_transform_only_dummies_);
8425
8426           t = build_decl (FUNCTION_DECL,
8427                           ffecom_get_external_identifier_ (s),
8428                           ffecom_tree_blockdata_type);
8429           DECL_EXTERNAL (t) = 1;
8430           TREE_PUBLIC (t) = 1;
8431
8432           t = start_decl (t, FALSE);
8433           finish_decl (t, NULL_TREE, FALSE);
8434
8435           ffecom_save_tree_forever (t);
8436
8437           break;
8438
8439         case FFEINFO_whereCOMMON:
8440         case FFEINFO_whereDUMMY:
8441         case FFEINFO_whereRESULT:
8442         case FFEINFO_whereFLEETING:
8443         case FFEINFO_whereFLEETING_CADDR:
8444         case FFEINFO_whereFLEETING_IADDR:
8445         case FFEINFO_whereIMMEDIATE:
8446         case FFEINFO_whereINTRINSIC:
8447         case FFEINFO_whereCONSTANT:
8448         case FFEINFO_whereCONSTANT_SUBOBJECT:
8449         default:
8450           assert ("BLOCKDATA where unheard of" == NULL);
8451           /* Fall through. */
8452         case FFEINFO_whereANY:
8453           t = error_mark_node;
8454           break;
8455         }
8456       break;
8457
8458     case FFEINFO_kindCOMMON:
8459       switch (ffeinfo_where (ffesymbol_info (s)))
8460         {
8461         case FFEINFO_whereLOCAL:
8462           assert (!ffecom_transform_only_dummies_);
8463           ffecom_transform_common_ (s);
8464           break;
8465
8466         case FFEINFO_whereNONE:
8467         case FFEINFO_whereCOMMON:
8468         case FFEINFO_whereDUMMY:
8469         case FFEINFO_whereGLOBAL:
8470         case FFEINFO_whereRESULT:
8471         case FFEINFO_whereFLEETING:
8472         case FFEINFO_whereFLEETING_CADDR:
8473         case FFEINFO_whereFLEETING_IADDR:
8474         case FFEINFO_whereIMMEDIATE:
8475         case FFEINFO_whereINTRINSIC:
8476         case FFEINFO_whereCONSTANT:
8477         case FFEINFO_whereCONSTANT_SUBOBJECT:
8478         default:
8479           assert ("COMMON where unheard of" == NULL);
8480           /* Fall through. */
8481         case FFEINFO_whereANY:
8482           t = error_mark_node;
8483           break;
8484         }
8485       break;
8486
8487     case FFEINFO_kindCONSTRUCT:
8488       switch (ffeinfo_where (ffesymbol_info (s)))
8489         {
8490         case FFEINFO_whereLOCAL:
8491           assert (!ffecom_transform_only_dummies_);
8492           break;
8493
8494         case FFEINFO_whereNONE:
8495         case FFEINFO_whereCOMMON:
8496         case FFEINFO_whereDUMMY:
8497         case FFEINFO_whereGLOBAL:
8498         case FFEINFO_whereRESULT:
8499         case FFEINFO_whereFLEETING:
8500         case FFEINFO_whereFLEETING_CADDR:
8501         case FFEINFO_whereFLEETING_IADDR:
8502         case FFEINFO_whereIMMEDIATE:
8503         case FFEINFO_whereINTRINSIC:
8504         case FFEINFO_whereCONSTANT:
8505         case FFEINFO_whereCONSTANT_SUBOBJECT:
8506         default:
8507           assert ("CONSTRUCT where unheard of" == NULL);
8508           /* Fall through. */
8509         case FFEINFO_whereANY:
8510           t = error_mark_node;
8511           break;
8512         }
8513       break;
8514
8515     case FFEINFO_kindNAMELIST:
8516       switch (ffeinfo_where (ffesymbol_info (s)))
8517         {
8518         case FFEINFO_whereLOCAL:
8519           assert (!ffecom_transform_only_dummies_);
8520           t = ffecom_transform_namelist_ (s);
8521           break;
8522
8523         case FFEINFO_whereNONE:
8524         case FFEINFO_whereCOMMON:
8525         case FFEINFO_whereDUMMY:
8526         case FFEINFO_whereGLOBAL:
8527         case FFEINFO_whereRESULT:
8528         case FFEINFO_whereFLEETING:
8529         case FFEINFO_whereFLEETING_CADDR:
8530         case FFEINFO_whereFLEETING_IADDR:
8531         case FFEINFO_whereIMMEDIATE:
8532         case FFEINFO_whereINTRINSIC:
8533         case FFEINFO_whereCONSTANT:
8534         case FFEINFO_whereCONSTANT_SUBOBJECT:
8535         default:
8536           assert ("NAMELIST where unheard of" == NULL);
8537           /* Fall through. */
8538         case FFEINFO_whereANY:
8539           t = error_mark_node;
8540           break;
8541         }
8542       break;
8543
8544     default:
8545       assert ("kind unheard of" == NULL);
8546       /* Fall through. */
8547     case FFEINFO_kindANY:
8548       t = error_mark_node;
8549       break;
8550     }
8551
8552   ffesymbol_hook (s).decl_tree = t;
8553   ffesymbol_hook (s).length_tree = tlen;
8554   ffesymbol_hook (s).addr = addr;
8555
8556   lineno = old_lineno;
8557   input_filename = old_input_filename;
8558
8559   return s;
8560 }
8561
8562 #endif
8563 /* Transform into ASSIGNable symbol.
8564
8565    Symbol has already been transformed, but for whatever reason, the
8566    resulting decl_tree has been deemed not usable for an ASSIGN target.
8567    (E.g. it isn't wide enough to hold a pointer.)  So, here we invent
8568    another local symbol of type void * and stuff that in the assign_tree
8569    argument.  The F77/F90 standards allow this implementation.  */
8570
8571 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8572 static ffesymbol
8573 ffecom_sym_transform_assign_ (ffesymbol s)
8574 {
8575   tree t;                       /* Transformed thingy. */
8576   int yes;
8577   int old_lineno = lineno;
8578   char *old_input_filename = input_filename;
8579
8580   if (ffesymbol_sfdummyparent (s) == NULL)
8581     {
8582       input_filename = ffesymbol_where_filename (s);
8583       lineno = ffesymbol_where_filelinenum (s);
8584     }
8585   else
8586     {
8587       ffesymbol sf = ffesymbol_sfdummyparent (s);
8588
8589       input_filename = ffesymbol_where_filename (sf);
8590       lineno = ffesymbol_where_filelinenum (sf);
8591     }
8592
8593   assert (!ffecom_transform_only_dummies_);
8594
8595   yes = suspend_momentary ();
8596
8597   t = build_decl (VAR_DECL,
8598                   ffecom_get_invented_identifier ("__g77_ASSIGN_%s",
8599                                                    ffesymbol_text (s)),
8600                   TREE_TYPE (null_pointer_node));
8601
8602   switch (ffesymbol_where (s))
8603     {
8604     case FFEINFO_whereLOCAL:
8605       /* Unlike for regular vars, SAVE status is easy to determine for
8606          ASSIGNed vars, since there's no initialization, there's no
8607          effective storage association (so "SAVE J" does not apply to
8608          K even given "EQUIVALENCE (J,K)"), there's no size issue
8609          to worry about, etc.  */
8610       if ((ffesymbol_is_save (s) || ffe_is_saveall ())
8611           && (ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8612           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA))
8613         TREE_STATIC (t) = 1;    /* SAVEd in proc, make static. */
8614       else
8615         TREE_STATIC (t) = 0;    /* No need to make static. */
8616       break;
8617
8618     case FFEINFO_whereCOMMON:
8619       TREE_STATIC (t) = 1;      /* Assume COMMONs always SAVEd. */
8620       break;
8621
8622     case FFEINFO_whereDUMMY:
8623       /* Note that twinning a DUMMY means the caller won't see
8624          the ASSIGNed value.  But both F77 and F90 allow implementations
8625          to do this, i.e. disallow Fortran code that would try and
8626          take advantage of actually putting a label into a variable
8627          via a dummy argument (or any other storage association, for
8628          that matter).  */
8629       TREE_STATIC (t) = 0;
8630       break;
8631
8632     default:
8633       TREE_STATIC (t) = 0;
8634       break;
8635     }
8636
8637   t = start_decl (t, FALSE);
8638   finish_decl (t, NULL_TREE, FALSE);
8639
8640   resume_momentary (yes);
8641
8642   ffesymbol_hook (s).assign_tree = t;
8643
8644   lineno = old_lineno;
8645   input_filename = old_input_filename;
8646
8647   return s;
8648 }
8649
8650 #endif
8651 /* Implement COMMON area in back end.
8652
8653    Because COMMON-based variables can be referenced in the dimension
8654    expressions of dummy (adjustable) arrays, and because dummies
8655    (in the gcc back end) need to be put in the outer binding level
8656    of a function (which has two binding levels, the outer holding
8657    the dummies and the inner holding the other vars), special care
8658    must be taken to handle COMMON areas.
8659
8660    The current strategy is basically to always tell the back end about
8661    the COMMON area as a top-level external reference to just a block
8662    of storage of the master type of that area (e.g. integer, real,
8663    character, whatever -- not a structure).  As a distinct action,
8664    if initial values are provided, tell the back end about the area
8665    as a top-level non-external (initialized) area and remember not to
8666    allow further initialization or expansion of the area.  Meanwhile,
8667    if no initialization happens at all, tell the back end about
8668    the largest size we've seen declared so the space does get reserved.
8669    (This function doesn't handle all that stuff, but it does some
8670    of the important things.)
8671
8672    Meanwhile, for COMMON variables themselves, just keep creating
8673    references like *((float *) (&common_area + offset)) each time
8674    we reference the variable.  In other words, don't make a VAR_DECL
8675    or any kind of component reference (like we used to do before 0.4),
8676    though we might do that as well just for debugging purposes (and
8677    stuff the rtl with the appropriate offset expression).  */
8678
8679 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8680 static void
8681 ffecom_transform_common_ (ffesymbol s)
8682 {
8683   ffestorag st = ffesymbol_storage (s);
8684   ffeglobal g = ffesymbol_global (s);
8685   tree cbt;
8686   tree cbtype;
8687   tree init;
8688   tree high;
8689   bool is_init = ffestorag_is_init (st);
8690
8691   assert (st != NULL);
8692
8693   if ((g == NULL)
8694       || (ffeglobal_type (g) != FFEGLOBAL_typeCOMMON))
8695     return;
8696
8697   /* First update the size of the area in global terms.  */
8698
8699   ffeglobal_size_common (s, ffestorag_size (st));
8700
8701   if (!ffeglobal_common_init (g))
8702     is_init = FALSE;    /* No explicit init, don't let erroneous joins init. */
8703
8704   cbt = ffeglobal_hook (g);
8705
8706   /* If we already have declared this common block for a previous program
8707      unit, and either we already initialized it or we don't have new
8708      initialization for it, just return what we have without changing it.  */
8709
8710   if ((cbt != NULL_TREE)
8711       && (!is_init
8712           || !DECL_EXTERNAL (cbt)))
8713     {
8714       if (st->hook == NULL) ffestorag_set_hook (st, cbt);
8715       return;
8716     }
8717
8718   /* Process inits.  */
8719
8720   if (is_init)
8721     {
8722       if (ffestorag_init (st) != NULL)
8723         {
8724           ffebld sexp;
8725
8726           /* Set the padding for the expression, so ffecom_expr
8727              knows to insert that many zeros.  */
8728           switch (ffebld_op (sexp = ffestorag_init (st)))
8729             {
8730             case FFEBLD_opCONTER:
8731               ffebld_conter_set_pad (sexp, ffestorag_modulo (st));
8732               break;
8733
8734             case FFEBLD_opARRTER:
8735               ffebld_arrter_set_pad (sexp, ffestorag_modulo (st));
8736               break;
8737
8738             case FFEBLD_opACCTER:
8739               ffebld_accter_set_pad (sexp, ffestorag_modulo (st));
8740               break;
8741
8742             default:
8743               assert ("bad op for cmn init (pad)" == NULL);
8744               break;
8745             }
8746
8747           init = ffecom_expr (sexp);
8748           if (init == error_mark_node)
8749             {                   /* Hopefully the back end complained! */
8750               init = NULL_TREE;
8751               if (cbt != NULL_TREE)
8752                 return;
8753             }
8754         }
8755       else
8756         init = error_mark_node;
8757     }
8758   else
8759     init = NULL_TREE;
8760
8761   /* cbtype must be permanently allocated!  */
8762
8763   /* Allocate the MAX of the areas so far, seen filewide.  */
8764   high = build_int_2 ((ffeglobal_common_size (g)
8765                        + ffeglobal_common_pad (g)) - 1, 0);
8766   TREE_TYPE (high) = ffecom_integer_type_node;
8767
8768   if (init)
8769     cbtype = build_array_type (char_type_node,
8770                                build_range_type (integer_type_node,
8771                                                  integer_zero_node,
8772                                                  high));
8773   else
8774     cbtype = build_array_type (char_type_node, NULL_TREE);
8775
8776   if (cbt == NULL_TREE)
8777     {
8778       cbt
8779         = build_decl (VAR_DECL,
8780                       ffecom_get_external_identifier_ (s),
8781                       cbtype);
8782       TREE_STATIC (cbt) = 1;
8783       TREE_PUBLIC (cbt) = 1;
8784     }
8785   else
8786     {
8787       assert (is_init);
8788       TREE_TYPE (cbt) = cbtype;
8789     }
8790   DECL_EXTERNAL (cbt) = init ? 0 : 1;
8791   DECL_INITIAL (cbt) = init ? error_mark_node : NULL_TREE;
8792
8793   cbt = start_decl (cbt, TRUE);
8794   if (ffeglobal_hook (g) != NULL)
8795     assert (cbt == ffeglobal_hook (g));
8796
8797   assert (!init || !DECL_EXTERNAL (cbt));
8798
8799   /* Make sure that any type can live in COMMON and be referenced
8800      without getting a bus error.  We could pick the most restrictive
8801      alignment of all entities actually placed in the COMMON, but
8802      this seems easy enough.  */
8803
8804   DECL_ALIGN (cbt) = BIGGEST_ALIGNMENT;
8805
8806   if (is_init && (ffestorag_init (st) == NULL))
8807     init = ffecom_init_zero_ (cbt);
8808
8809   finish_decl (cbt, init, TRUE);
8810
8811   if (is_init)
8812     ffestorag_set_init (st, ffebld_new_any ());
8813
8814   if (init)
8815     {
8816       assert (DECL_SIZE_UNIT (cbt) != NULL_TREE);
8817       assert (TREE_CODE (DECL_SIZE_UNIT (cbt)) == INTEGER_CST);
8818       assert (0 == compare_tree_int (DECL_SIZE_UNIT (cbt),
8819                                      (ffeglobal_common_size (g)
8820                                       + ffeglobal_common_pad (g))));
8821     }
8822
8823   ffeglobal_set_hook (g, cbt);
8824
8825   ffestorag_set_hook (st, cbt);
8826
8827   ffecom_save_tree_forever (cbt);
8828 }
8829
8830 #endif
8831 /* Make master area for local EQUIVALENCE.  */
8832
8833 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8834 static void
8835 ffecom_transform_equiv_ (ffestorag eqst)
8836 {
8837   tree eqt;
8838   tree eqtype;
8839   tree init;
8840   tree high;
8841   bool is_init = ffestorag_is_init (eqst);
8842   int yes;
8843
8844   assert (eqst != NULL);
8845
8846   eqt = ffestorag_hook (eqst);
8847
8848   if (eqt != NULL_TREE)
8849     return;
8850
8851   /* Process inits.  */
8852
8853   if (is_init)
8854     {
8855       if (ffestorag_init (eqst) != NULL)
8856         {
8857           ffebld sexp;
8858
8859           /* Set the padding for the expression, so ffecom_expr
8860              knows to insert that many zeros.  */
8861           switch (ffebld_op (sexp = ffestorag_init (eqst)))
8862             {
8863             case FFEBLD_opCONTER:
8864               ffebld_conter_set_pad (sexp, ffestorag_modulo (eqst));
8865               break;
8866
8867             case FFEBLD_opARRTER:
8868               ffebld_arrter_set_pad (sexp, ffestorag_modulo (eqst));
8869               break;
8870
8871             case FFEBLD_opACCTER:
8872               ffebld_accter_set_pad (sexp, ffestorag_modulo (eqst));
8873               break;
8874
8875             default:
8876               assert ("bad op for eqv init (pad)" == NULL);
8877               break;
8878             }
8879
8880           init = ffecom_expr (sexp);
8881           if (init == error_mark_node)
8882             init = NULL_TREE;   /* Hopefully the back end complained! */
8883         }
8884       else
8885         init = error_mark_node;
8886     }
8887   else if (ffe_is_init_local_zero ())
8888     init = error_mark_node;
8889   else
8890     init = NULL_TREE;
8891
8892   ffecom_member_namelisted_ = FALSE;
8893   ffestorag_drive (ffestorag_list_equivs (eqst),
8894                    &ffecom_member_phase1_,
8895                    eqst);
8896
8897   yes = suspend_momentary ();
8898
8899   high = build_int_2 ((ffestorag_size (eqst)
8900                        + ffestorag_modulo (eqst)) - 1, 0);
8901   TREE_TYPE (high) = ffecom_integer_type_node;
8902
8903   eqtype = build_array_type (char_type_node,
8904                              build_range_type (ffecom_integer_type_node,
8905                                                ffecom_integer_zero_node,
8906                                                high));
8907
8908   eqt = build_decl (VAR_DECL,
8909                     ffecom_get_invented_identifier ("__g77_equiv_%s",
8910                                                     ffesymbol_text
8911                                                     (ffestorag_symbol (eqst))),
8912                     eqtype);
8913   DECL_EXTERNAL (eqt) = 0;
8914   if (is_init
8915       || ffecom_member_namelisted_
8916 #ifdef FFECOM_sizeMAXSTACKITEM
8917       || (ffestorag_size (eqst) > FFECOM_sizeMAXSTACKITEM)
8918 #endif
8919       || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8920           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
8921           && (ffestorag_is_save (eqst) || ffe_is_saveall ())))
8922     TREE_STATIC (eqt) = 1;
8923   else
8924     TREE_STATIC (eqt) = 0;
8925   TREE_PUBLIC (eqt) = 0;
8926   DECL_CONTEXT (eqt) = current_function_decl;
8927   if (init)
8928     DECL_INITIAL (eqt) = error_mark_node;
8929   else
8930     DECL_INITIAL (eqt) = NULL_TREE;
8931
8932   eqt = start_decl (eqt, FALSE);
8933
8934   /* Make sure that any type can live in EQUIVALENCE and be referenced
8935      without getting a bus error.  We could pick the most restrictive
8936      alignment of all entities actually placed in the EQUIVALENCE, but
8937      this seems easy enough.  */
8938
8939   DECL_ALIGN (eqt) = BIGGEST_ALIGNMENT;
8940
8941   if ((!is_init && ffe_is_init_local_zero ())
8942       || (is_init && (ffestorag_init (eqst) == NULL)))
8943     init = ffecom_init_zero_ (eqt);
8944
8945   finish_decl (eqt, init, FALSE);
8946
8947   if (is_init)
8948     ffestorag_set_init (eqst, ffebld_new_any ());
8949
8950   {
8951     assert (TREE_CODE (DECL_SIZE_UNIT (eqt)) == INTEGER_CST);
8952     assert (0 == compare_tree_int (DECL_SIZE_UNIT (eqt),
8953                                    (ffestorag_size (eqst)
8954                                     + ffestorag_modulo (eqst))));
8955   }
8956
8957   ffestorag_set_hook (eqst, eqt);
8958
8959 #ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
8960   ffestorag_drive (ffestorag_list_equivs (eqst),
8961                    &ffecom_member_phase2_,
8962                    eqst);
8963 #endif
8964
8965   resume_momentary (yes);
8966 }
8967
8968 #endif
8969 /* Implement NAMELIST in back end.  See f2c/format.c for more info.  */
8970
8971 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8972 static tree
8973 ffecom_transform_namelist_ (ffesymbol s)
8974 {
8975   tree nmlt;
8976   tree nmltype = ffecom_type_namelist_ ();
8977   tree nmlinits;
8978   tree nameinit;
8979   tree varsinit;
8980   tree nvarsinit;
8981   tree field;
8982   tree high;
8983   int yes;
8984   int i;
8985   static int mynumber = 0;
8986
8987   yes = suspend_momentary ();
8988
8989   nmlt = build_decl (VAR_DECL,
8990                      ffecom_get_invented_identifier ("__g77_namelist_%d",
8991                                                      mynumber++),
8992                      nmltype);
8993   TREE_STATIC (nmlt) = 1;
8994   DECL_INITIAL (nmlt) = error_mark_node;
8995
8996   nmlt = start_decl (nmlt, FALSE);
8997
8998   /* Process inits.  */
8999
9000   i = strlen (ffesymbol_text (s));
9001
9002   high = build_int_2 (i, 0);
9003   TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
9004
9005   nameinit = ffecom_build_f2c_string_ (i + 1,
9006                                        ffesymbol_text (s));
9007   TREE_TYPE (nameinit)
9008     = build_type_variant
9009     (build_array_type
9010      (char_type_node,
9011       build_range_type (ffecom_f2c_ftnlen_type_node,
9012                         ffecom_f2c_ftnlen_one_node,
9013                         high)),
9014      1, 0);
9015   TREE_CONSTANT (nameinit) = 1;
9016   TREE_STATIC (nameinit) = 1;
9017   nameinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (nameinit)),
9018                        nameinit);
9019
9020   varsinit = ffecom_vardesc_array_ (s);
9021   varsinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (varsinit)),
9022                        varsinit);
9023   TREE_CONSTANT (varsinit) = 1;
9024   TREE_STATIC (varsinit) = 1;
9025
9026   {
9027     ffebld b;
9028
9029     for (i = 0, b = ffesymbol_namelist (s); b != NULL; b = ffebld_trail (b))
9030       ++i;
9031   }
9032   nvarsinit = build_int_2 (i, 0);
9033   TREE_TYPE (nvarsinit) = integer_type_node;
9034   TREE_CONSTANT (nvarsinit) = 1;
9035   TREE_STATIC (nvarsinit) = 1;
9036
9037   nmlinits = build_tree_list ((field = TYPE_FIELDS (nmltype)), nameinit);
9038   TREE_CHAIN (nmlinits) = build_tree_list ((field = TREE_CHAIN (field)),
9039                                            varsinit);
9040   TREE_CHAIN (TREE_CHAIN (nmlinits))
9041     = build_tree_list ((field = TREE_CHAIN (field)), nvarsinit);
9042
9043   nmlinits = build (CONSTRUCTOR, nmltype, NULL_TREE, nmlinits);
9044   TREE_CONSTANT (nmlinits) = 1;
9045   TREE_STATIC (nmlinits) = 1;
9046
9047   finish_decl (nmlt, nmlinits, FALSE);
9048
9049   nmlt = ffecom_1 (ADDR_EXPR, build_pointer_type (nmltype), nmlt);
9050
9051   resume_momentary (yes);
9052
9053   return nmlt;
9054 }
9055
9056 #endif
9057
9058 /* A subroutine of ffecom_tree_canonize_ref_.  The incoming tree is
9059    analyzed on the assumption it is calculating a pointer to be
9060    indirected through.  It must return the proper decl and offset,
9061    taking into account different units of measurements for offsets.  */
9062
9063 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9064 static void
9065 ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
9066                            tree t)
9067 {
9068   switch (TREE_CODE (t))
9069     {
9070     case NOP_EXPR:
9071     case CONVERT_EXPR:
9072     case NON_LVALUE_EXPR:
9073       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
9074       break;
9075
9076     case PLUS_EXPR:
9077       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
9078       if ((*decl == NULL_TREE)
9079           || (*decl == error_mark_node))
9080         break;
9081
9082       if (TREE_CODE (TREE_OPERAND (t, 1)) == INTEGER_CST)
9083         {
9084           /* An offset into COMMON.  */
9085           *offset = fold (build (PLUS_EXPR, TREE_TYPE (*offset),
9086                                  *offset, TREE_OPERAND (t, 1)));
9087           /* Convert offset (presumably in bytes) into canonical units
9088              (presumably bits).  */
9089           *offset = fold (build (MULT_EXPR, TREE_TYPE (*offset),
9090                                  TYPE_SIZE (TREE_TYPE (TREE_TYPE (t))),
9091                                  *offset));
9092           break;
9093         }
9094       /* Not a COMMON reference, so an unrecognized pattern.  */
9095       *decl = error_mark_node;
9096       break;
9097
9098     case PARM_DECL:
9099       *decl = t;
9100       *offset = bitsize_zero_node;
9101       break;
9102
9103     case ADDR_EXPR:
9104       if (TREE_CODE (TREE_OPERAND (t, 0)) == VAR_DECL)
9105         {
9106           /* A reference to COMMON.  */
9107           *decl = TREE_OPERAND (t, 0);
9108           *offset = bitsize_zero_node;
9109           break;
9110         }
9111       /* Fall through.  */
9112     default:
9113       /* Not a COMMON reference, so an unrecognized pattern.  */
9114       *decl = error_mark_node;
9115       break;
9116     }
9117 }
9118 #endif
9119
9120 /* Given a tree that is possibly intended for use as an lvalue, return
9121    information representing a canonical view of that tree as a decl, an
9122    offset into that decl, and a size for the lvalue.
9123
9124    If there's no applicable decl, NULL_TREE is returned for the decl,
9125    and the other fields are left undefined.
9126
9127    If the tree doesn't fit the recognizable forms, an ERROR_MARK node
9128    is returned for the decl, and the other fields are left undefined.
9129
9130    Otherwise, the decl returned currently is either a VAR_DECL or a
9131    PARM_DECL.
9132
9133    The offset returned is always valid, but of course not necessarily
9134    a constant, and not necessarily converted into the appropriate
9135    type, leaving that up to the caller (so as to avoid that overhead
9136    if the decls being looked at are different anyway).
9137
9138    If the size cannot be determined (e.g. an adjustable array),
9139    an ERROR_MARK node is returned for the size.  Otherwise, the
9140    size returned is valid, not necessarily a constant, and not
9141    necessarily converted into the appropriate type as with the
9142    offset.
9143
9144    Note that the offset and size expressions are expressed in the
9145    base storage units (usually bits) rather than in the units of
9146    the type of the decl, because two decls with different types
9147    might overlap but with apparently non-overlapping array offsets,
9148    whereas converting the array offsets to consistant offsets will
9149    reveal the overlap.  */
9150
9151 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9152 static void
9153 ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
9154                            tree *size, tree t)
9155 {
9156   /* The default path is to report a nonexistant decl.  */
9157   *decl = NULL_TREE;
9158
9159   if (t == NULL_TREE)
9160     return;
9161
9162   switch (TREE_CODE (t))
9163     {
9164     case ERROR_MARK:
9165     case IDENTIFIER_NODE:
9166     case INTEGER_CST:
9167     case REAL_CST:
9168     case COMPLEX_CST:
9169     case STRING_CST:
9170     case CONST_DECL:
9171     case PLUS_EXPR:
9172     case MINUS_EXPR:
9173     case MULT_EXPR:
9174     case TRUNC_DIV_EXPR:
9175     case CEIL_DIV_EXPR:
9176     case FLOOR_DIV_EXPR:
9177     case ROUND_DIV_EXPR:
9178     case TRUNC_MOD_EXPR:
9179     case CEIL_MOD_EXPR:
9180     case FLOOR_MOD_EXPR:
9181     case ROUND_MOD_EXPR:
9182     case RDIV_EXPR:
9183     case EXACT_DIV_EXPR:
9184     case FIX_TRUNC_EXPR:
9185     case FIX_CEIL_EXPR:
9186     case FIX_FLOOR_EXPR:
9187     case FIX_ROUND_EXPR:
9188     case FLOAT_EXPR:
9189     case EXPON_EXPR:
9190     case NEGATE_EXPR:
9191     case MIN_EXPR:
9192     case MAX_EXPR:
9193     case ABS_EXPR:
9194     case FFS_EXPR:
9195     case LSHIFT_EXPR:
9196     case RSHIFT_EXPR:
9197     case LROTATE_EXPR:
9198     case RROTATE_EXPR:
9199     case BIT_IOR_EXPR:
9200     case BIT_XOR_EXPR:
9201     case BIT_AND_EXPR:
9202     case BIT_ANDTC_EXPR:
9203     case BIT_NOT_EXPR:
9204     case TRUTH_ANDIF_EXPR:
9205     case TRUTH_ORIF_EXPR:
9206     case TRUTH_AND_EXPR:
9207     case TRUTH_OR_EXPR:
9208     case TRUTH_XOR_EXPR:
9209     case TRUTH_NOT_EXPR:
9210     case LT_EXPR:
9211     case LE_EXPR:
9212     case GT_EXPR:
9213     case GE_EXPR:
9214     case EQ_EXPR:
9215     case NE_EXPR:
9216     case COMPLEX_EXPR:
9217     case CONJ_EXPR:
9218     case REALPART_EXPR:
9219     case IMAGPART_EXPR:
9220     case LABEL_EXPR:
9221     case COMPONENT_REF:
9222     case COMPOUND_EXPR:
9223     case ADDR_EXPR:
9224       return;
9225
9226     case VAR_DECL:
9227     case PARM_DECL:
9228       *decl = t;
9229       *offset = bitsize_zero_node;
9230       *size = TYPE_SIZE (TREE_TYPE (t));
9231       return;
9232
9233     case ARRAY_REF:
9234       {
9235         tree array = TREE_OPERAND (t, 0);
9236         tree element = TREE_OPERAND (t, 1);
9237         tree init_offset;
9238
9239         if ((array == NULL_TREE)
9240             || (element == NULL_TREE))
9241           {
9242             *decl = error_mark_node;
9243             return;
9244           }
9245
9246         ffecom_tree_canonize_ref_ (decl, &init_offset, size,
9247                                    array);
9248         if ((*decl == NULL_TREE)
9249             || (*decl == error_mark_node))
9250           return;
9251
9252         *offset
9253           = size_binop (MULT_EXPR,
9254                         TYPE_SIZE (TREE_TYPE (TREE_TYPE (array))),
9255                         convert (sizetype,
9256                                  fold (build (MINUS_EXPR, TREE_TYPE (element),
9257                                               element,
9258                                               TYPE_MIN_VALUE
9259                                               (TYPE_DOMAIN
9260                                                (TREE_TYPE (array)))))));;
9261
9262         *offset = size_binop (PLUS_EXPR, convert (sizetype, init_offset),
9263                               *offset);
9264
9265         *size = TYPE_SIZE (TREE_TYPE (t));
9266         return;
9267       }
9268
9269     case INDIRECT_REF:
9270
9271       /* Most of this code is to handle references to COMMON.  And so
9272          far that is useful only for calling library functions, since
9273          external (user) functions might reference common areas.  But
9274          even calling an external function, it's worthwhile to decode
9275          COMMON references because if not storing into COMMON, we don't
9276          want COMMON-based arguments to gratuitously force use of a
9277          temporary.  */
9278
9279       *size = TYPE_SIZE (TREE_TYPE (t));
9280
9281       ffecom_tree_canonize_ptr_ (decl, offset,
9282                                  TREE_OPERAND (t, 0));
9283
9284       return;
9285
9286     case CONVERT_EXPR:
9287     case NOP_EXPR:
9288     case MODIFY_EXPR:
9289     case NON_LVALUE_EXPR:
9290     case RESULT_DECL:
9291     case FIELD_DECL:
9292     case COND_EXPR:             /* More cases than we can handle. */
9293     case SAVE_EXPR:
9294     case REFERENCE_EXPR:
9295     case PREDECREMENT_EXPR:
9296     case PREINCREMENT_EXPR:
9297     case POSTDECREMENT_EXPR:
9298     case POSTINCREMENT_EXPR:
9299     case CALL_EXPR:
9300     default:
9301       *decl = error_mark_node;
9302       return;
9303     }
9304 }
9305 #endif
9306
9307 /* Do divide operation appropriate to type of operands.  */
9308
9309 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9310 static tree
9311 ffecom_tree_divide_ (tree tree_type, tree left, tree right,
9312                      tree dest_tree, ffebld dest, bool *dest_used,
9313                      tree hook)
9314 {
9315   if ((left == error_mark_node)
9316       || (right == error_mark_node))
9317     return error_mark_node;
9318
9319   switch (TREE_CODE (tree_type))
9320     {
9321     case INTEGER_TYPE:
9322       return ffecom_2 (TRUNC_DIV_EXPR, tree_type,
9323                        left,
9324                        right);
9325
9326     case COMPLEX_TYPE:
9327       if (! optimize_size)
9328         return ffecom_2 (RDIV_EXPR, tree_type,
9329                          left,
9330                          right);
9331       {
9332         ffecomGfrt ix;
9333
9334         if (TREE_TYPE (tree_type)
9335             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9336           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9337         else
9338           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9339
9340         left = ffecom_1 (ADDR_EXPR,
9341                          build_pointer_type (TREE_TYPE (left)),
9342                          left);
9343         left = build_tree_list (NULL_TREE, left);
9344         right = ffecom_1 (ADDR_EXPR,
9345                           build_pointer_type (TREE_TYPE (right)),
9346                           right);
9347         right = build_tree_list (NULL_TREE, right);
9348         TREE_CHAIN (left) = right;
9349
9350         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9351                              ffecom_gfrt_kindtype (ix),
9352                              ffe_is_f2c_library (),
9353                              tree_type,
9354                              left,
9355                              dest_tree, dest, dest_used,
9356                              NULL_TREE, TRUE, hook);
9357       }
9358       break;
9359
9360     case RECORD_TYPE:
9361       {
9362         ffecomGfrt ix;
9363
9364         if (TREE_TYPE (TYPE_FIELDS (tree_type))
9365             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9366           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9367         else
9368           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9369
9370         left = ffecom_1 (ADDR_EXPR,
9371                          build_pointer_type (TREE_TYPE (left)),
9372                          left);
9373         left = build_tree_list (NULL_TREE, left);
9374         right = ffecom_1 (ADDR_EXPR,
9375                           build_pointer_type (TREE_TYPE (right)),
9376                           right);
9377         right = build_tree_list (NULL_TREE, right);
9378         TREE_CHAIN (left) = right;
9379
9380         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9381                              ffecom_gfrt_kindtype (ix),
9382                              ffe_is_f2c_library (),
9383                              tree_type,
9384                              left,
9385                              dest_tree, dest, dest_used,
9386                              NULL_TREE, TRUE, hook);
9387       }
9388       break;
9389
9390     default:
9391       return ffecom_2 (RDIV_EXPR, tree_type,
9392                        left,
9393                        right);
9394     }
9395 }
9396
9397 #endif
9398 /* Build type info for non-dummy variable.  */
9399
9400 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9401 static tree
9402 ffecom_type_localvar_ (ffesymbol s, ffeinfoBasictype bt,
9403                        ffeinfoKindtype kt)
9404 {
9405   tree type;
9406   ffebld dl;
9407   ffebld dim;
9408   tree lowt;
9409   tree hight;
9410
9411   type = ffecom_tree_type[bt][kt];
9412   if (bt == FFEINFO_basictypeCHARACTER)
9413     {
9414       hight = build_int_2 (ffesymbol_size (s), 0);
9415       TREE_TYPE (hight) = ffecom_f2c_ftnlen_type_node;
9416
9417       type
9418         = build_array_type
9419           (type,
9420            build_range_type (ffecom_f2c_ftnlen_type_node,
9421                              ffecom_f2c_ftnlen_one_node,
9422                              hight));
9423       type = ffecom_check_size_overflow_ (s, type, FALSE);
9424     }
9425
9426   for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
9427     {
9428       if (type == error_mark_node)
9429         break;
9430
9431       dim = ffebld_head (dl);
9432       assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
9433
9434       if (ffebld_left (dim) == NULL)
9435         lowt = integer_one_node;
9436       else
9437         lowt = ffecom_expr (ffebld_left (dim));
9438
9439       if (TREE_CODE (lowt) != INTEGER_CST)
9440         lowt = variable_size (lowt);
9441
9442       assert (ffebld_right (dim) != NULL);
9443       hight = ffecom_expr (ffebld_right (dim));
9444
9445       if (TREE_CODE (hight) != INTEGER_CST)
9446         hight = variable_size (hight);
9447
9448       type = build_array_type (type,
9449                                build_range_type (ffecom_integer_type_node,
9450                                                  lowt, hight));
9451       type = ffecom_check_size_overflow_ (s, type, FALSE);
9452     }
9453
9454   return type;
9455 }
9456
9457 #endif
9458 /* Build Namelist type.  */
9459
9460 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9461 static tree
9462 ffecom_type_namelist_ ()
9463 {
9464   static tree type = NULL_TREE;
9465
9466   if (type == NULL_TREE)
9467     {
9468       static tree namefield, varsfield, nvarsfield;
9469       tree vardesctype;
9470
9471       vardesctype = ffecom_type_vardesc_ ();
9472
9473       type = make_node (RECORD_TYPE);
9474
9475       vardesctype = build_pointer_type (build_pointer_type (vardesctype));
9476
9477       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9478                                      string_type_node);
9479       varsfield = ffecom_decl_field (type, namefield, "vars", vardesctype);
9480       nvarsfield = ffecom_decl_field (type, varsfield, "nvars",
9481                                       integer_type_node);
9482
9483       TYPE_FIELDS (type) = namefield;
9484       layout_type (type);
9485
9486       ggc_add_tree_root (&type, 1);
9487     }
9488
9489   return type;
9490 }
9491
9492 #endif
9493
9494 /* Build Vardesc type.  */
9495
9496 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9497 static tree
9498 ffecom_type_vardesc_ ()
9499 {
9500   static tree type = NULL_TREE;
9501   static tree namefield, addrfield, dimsfield, typefield;
9502
9503   if (type == NULL_TREE)
9504     {
9505       type = make_node (RECORD_TYPE);
9506
9507       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9508                                      string_type_node);
9509       addrfield = ffecom_decl_field (type, namefield, "addr",
9510                                      string_type_node);
9511       dimsfield = ffecom_decl_field (type, addrfield, "dims",
9512                                      ffecom_f2c_ptr_to_ftnlen_type_node);
9513       typefield = ffecom_decl_field (type, dimsfield, "type",
9514                                      integer_type_node);
9515
9516       TYPE_FIELDS (type) = namefield;
9517       layout_type (type);
9518
9519       ggc_add_tree_root (&type, 1);
9520     }
9521
9522   return type;
9523 }
9524
9525 #endif
9526
9527 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9528 static tree
9529 ffecom_vardesc_ (ffebld expr)
9530 {
9531   ffesymbol s;
9532
9533   assert (ffebld_op (expr) == FFEBLD_opSYMTER);
9534   s = ffebld_symter (expr);
9535
9536   if (ffesymbol_hook (s).vardesc_tree == NULL_TREE)
9537     {
9538       int i;
9539       tree vardesctype = ffecom_type_vardesc_ ();
9540       tree var;
9541       tree nameinit;
9542       tree dimsinit;
9543       tree addrinit;
9544       tree typeinit;
9545       tree field;
9546       tree varinits;
9547       int yes;
9548       static int mynumber = 0;
9549
9550       yes = suspend_momentary ();
9551
9552       var = build_decl (VAR_DECL,
9553                         ffecom_get_invented_identifier ("__g77_vardesc_%d",
9554                                                         mynumber++),
9555                         vardesctype);
9556       TREE_STATIC (var) = 1;
9557       DECL_INITIAL (var) = error_mark_node;
9558
9559       var = start_decl (var, FALSE);
9560
9561       /* Process inits.  */
9562
9563       nameinit = ffecom_build_f2c_string_ ((i = strlen (ffesymbol_text (s)))
9564                                            + 1,
9565                                            ffesymbol_text (s));
9566       TREE_TYPE (nameinit)
9567         = build_type_variant
9568         (build_array_type
9569          (char_type_node,
9570           build_range_type (integer_type_node,
9571                             integer_one_node,
9572                             build_int_2 (i, 0))),
9573          1, 0);
9574       TREE_CONSTANT (nameinit) = 1;
9575       TREE_STATIC (nameinit) = 1;
9576       nameinit = ffecom_1 (ADDR_EXPR,
9577                            build_pointer_type (TREE_TYPE (nameinit)),
9578                            nameinit);
9579
9580       addrinit = ffecom_arg_ptr_to_expr (expr, &typeinit);
9581
9582       dimsinit = ffecom_vardesc_dims_ (s);
9583
9584       if (typeinit == NULL_TREE)
9585         {
9586           ffeinfoBasictype bt = ffesymbol_basictype (s);
9587           ffeinfoKindtype kt = ffesymbol_kindtype (s);
9588           int tc = ffecom_f2c_typecode (bt, kt);
9589
9590           assert (tc != -1);
9591           typeinit = build_int_2 (tc, (tc < 0) ? -1 : 0);
9592         }
9593       else
9594         typeinit = ffecom_1 (NEGATE_EXPR, TREE_TYPE (typeinit), typeinit);
9595
9596       varinits = build_tree_list ((field = TYPE_FIELDS (vardesctype)),
9597                                   nameinit);
9598       TREE_CHAIN (varinits) = build_tree_list ((field = TREE_CHAIN (field)),
9599                                                addrinit);
9600       TREE_CHAIN (TREE_CHAIN (varinits))
9601         = build_tree_list ((field = TREE_CHAIN (field)), dimsinit);
9602       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits)))
9603         = build_tree_list ((field = TREE_CHAIN (field)), typeinit);
9604
9605       varinits = build (CONSTRUCTOR, vardesctype, NULL_TREE, varinits);
9606       TREE_CONSTANT (varinits) = 1;
9607       TREE_STATIC (varinits) = 1;
9608
9609       finish_decl (var, varinits, FALSE);
9610
9611       var = ffecom_1 (ADDR_EXPR, build_pointer_type (vardesctype), var);
9612
9613       resume_momentary (yes);
9614
9615       ffesymbol_hook (s).vardesc_tree = var;
9616     }
9617
9618   return ffesymbol_hook (s).vardesc_tree;
9619 }
9620
9621 #endif
9622 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9623 static tree
9624 ffecom_vardesc_array_ (ffesymbol s)
9625 {
9626   ffebld b;
9627   tree list;
9628   tree item = NULL_TREE;
9629   tree var;
9630   int i;
9631   int yes;
9632   static int mynumber = 0;
9633
9634   for (i = 0, list = NULL_TREE, b = ffesymbol_namelist (s);
9635        b != NULL;
9636        b = ffebld_trail (b), ++i)
9637     {
9638       tree t;
9639
9640       t = ffecom_vardesc_ (ffebld_head (b));
9641
9642       if (list == NULL_TREE)
9643         list = item = build_tree_list (NULL_TREE, t);
9644       else
9645         {
9646           TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9647           item = TREE_CHAIN (item);
9648         }
9649     }
9650
9651   yes = suspend_momentary ();
9652
9653   item = build_array_type (build_pointer_type (ffecom_type_vardesc_ ()),
9654                            build_range_type (integer_type_node,
9655                                              integer_one_node,
9656                                              build_int_2 (i, 0)));
9657   list = build (CONSTRUCTOR, item, NULL_TREE, list);
9658   TREE_CONSTANT (list) = 1;
9659   TREE_STATIC (list) = 1;
9660
9661   var = ffecom_get_invented_identifier ("__g77_vardesc_array_%d", mynumber++);
9662   var = build_decl (VAR_DECL, var, item);
9663   TREE_STATIC (var) = 1;
9664   DECL_INITIAL (var) = error_mark_node;
9665   var = start_decl (var, FALSE);
9666   finish_decl (var, list, FALSE);
9667
9668   resume_momentary (yes);
9669
9670   return var;
9671 }
9672
9673 #endif
9674 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9675 static tree
9676 ffecom_vardesc_dims_ (ffesymbol s)
9677 {
9678   if (ffesymbol_dims (s) == NULL)
9679     return convert (ffecom_f2c_ptr_to_ftnlen_type_node,
9680                     integer_zero_node);
9681
9682   {
9683     ffebld b;
9684     ffebld e;
9685     tree list;
9686     tree backlist;
9687     tree item = NULL_TREE;
9688     tree var;
9689     int yes;
9690     tree numdim;
9691     tree numelem;
9692     tree baseoff = NULL_TREE;
9693     static int mynumber = 0;
9694
9695     numdim = build_int_2 ((int) ffesymbol_rank (s), 0);
9696     TREE_TYPE (numdim) = ffecom_f2c_ftnlen_type_node;
9697
9698     numelem = ffecom_expr (ffesymbol_arraysize (s));
9699     TREE_TYPE (numelem) = ffecom_f2c_ftnlen_type_node;
9700
9701     list = NULL_TREE;
9702     backlist = NULL_TREE;
9703     for (b = ffesymbol_dims (s), e = ffesymbol_extents (s);
9704          b != NULL;
9705          b = ffebld_trail (b), e = ffebld_trail (e))
9706       {
9707         tree t;
9708         tree low;
9709         tree back;
9710
9711         if (ffebld_trail (b) == NULL)
9712           t = NULL_TREE;
9713         else
9714           {
9715             t = convert (ffecom_f2c_ftnlen_type_node,
9716                          ffecom_expr (ffebld_head (e)));
9717
9718             if (list == NULL_TREE)
9719               list = item = build_tree_list (NULL_TREE, t);
9720             else
9721               {
9722                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9723                 item = TREE_CHAIN (item);
9724               }
9725           }
9726
9727         if (ffebld_left (ffebld_head (b)) == NULL)
9728           low = ffecom_integer_one_node;
9729         else
9730           low = ffecom_expr (ffebld_left (ffebld_head (b)));
9731         low = convert (ffecom_f2c_ftnlen_type_node, low);
9732
9733         back = build_tree_list (low, t);
9734         TREE_CHAIN (back) = backlist;
9735         backlist = back;
9736       }
9737
9738     for (item = backlist; item != NULL_TREE; item = TREE_CHAIN (item))
9739       {
9740         if (TREE_VALUE (item) == NULL_TREE)
9741           baseoff = TREE_PURPOSE (item);
9742         else
9743           baseoff = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
9744                               TREE_PURPOSE (item),
9745                               ffecom_2 (MULT_EXPR,
9746                                         ffecom_f2c_ftnlen_type_node,
9747                                         TREE_VALUE (item),
9748                                         baseoff));
9749       }
9750
9751     /* backlist now dead, along with all TREE_PURPOSEs on it.  */
9752
9753     baseoff = build_tree_list (NULL_TREE, baseoff);
9754     TREE_CHAIN (baseoff) = list;
9755
9756     numelem = build_tree_list (NULL_TREE, numelem);
9757     TREE_CHAIN (numelem) = baseoff;
9758
9759     numdim = build_tree_list (NULL_TREE, numdim);
9760     TREE_CHAIN (numdim) = numelem;
9761
9762     yes = suspend_momentary ();
9763
9764     item = build_array_type (ffecom_f2c_ftnlen_type_node,
9765                              build_range_type (integer_type_node,
9766                                                integer_zero_node,
9767                                                build_int_2
9768                                                ((int) ffesymbol_rank (s)
9769                                                 + 2, 0)));
9770     list = build (CONSTRUCTOR, item, NULL_TREE, numdim);
9771     TREE_CONSTANT (list) = 1;
9772     TREE_STATIC (list) = 1;
9773
9774     var = ffecom_get_invented_identifier ("__g77_dims_%d", mynumber++);
9775     var = build_decl (VAR_DECL, var, item);
9776     TREE_STATIC (var) = 1;
9777     DECL_INITIAL (var) = error_mark_node;
9778     var = start_decl (var, FALSE);
9779     finish_decl (var, list, FALSE);
9780
9781     var = ffecom_1 (ADDR_EXPR, build_pointer_type (item), var);
9782
9783     resume_momentary (yes);
9784
9785     return var;
9786   }
9787 }
9788
9789 #endif
9790 /* Essentially does a "fold (build1 (code, type, node))" while checking
9791    for certain housekeeping things.
9792
9793    NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
9794    ffecom_1_fn instead.  */
9795
9796 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9797 tree
9798 ffecom_1 (enum tree_code code, tree type, tree node)
9799 {
9800   tree item;
9801
9802   if ((node == error_mark_node)
9803       || (type == error_mark_node))
9804     return error_mark_node;
9805
9806   if (code == ADDR_EXPR)
9807     {
9808       if (!mark_addressable (node))
9809         assert ("can't mark_addressable this node!" == NULL);
9810     }
9811
9812   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9813     {
9814       tree realtype;
9815
9816     case REALPART_EXPR:
9817       item = build (COMPONENT_REF, type, node, TYPE_FIELDS (TREE_TYPE (node)));
9818       break;
9819
9820     case IMAGPART_EXPR:
9821       item = build (COMPONENT_REF, type, node, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node))));
9822       break;
9823
9824
9825     case NEGATE_EXPR:
9826       if (TREE_CODE (type) != RECORD_TYPE)
9827         {
9828           item = build1 (code, type, node);
9829           break;
9830         }
9831       node = ffecom_stabilize_aggregate_ (node);
9832       realtype = TREE_TYPE (TYPE_FIELDS (type));
9833       item =
9834         ffecom_2 (COMPLEX_EXPR, type,
9835                   ffecom_1 (NEGATE_EXPR, realtype,
9836                             ffecom_1 (REALPART_EXPR, realtype,
9837                                       node)),
9838                   ffecom_1 (NEGATE_EXPR, realtype,
9839                             ffecom_1 (IMAGPART_EXPR, realtype,
9840                                       node)));
9841       break;
9842
9843     default:
9844       item = build1 (code, type, node);
9845       break;
9846     }
9847
9848   if (TREE_SIDE_EFFECTS (node))
9849     TREE_SIDE_EFFECTS (item) = 1;
9850   if ((code == ADDR_EXPR) && staticp (node))
9851     TREE_CONSTANT (item) = 1;
9852   return fold (item);
9853 }
9854 #endif
9855
9856 /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
9857    handles TREE_CODE (node) == FUNCTION_DECL.  In particular,
9858    does not set TREE_ADDRESSABLE (because calling an inline
9859    function does not mean the function needs to be separately
9860    compiled).  */
9861
9862 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9863 tree
9864 ffecom_1_fn (tree node)
9865 {
9866   tree item;
9867   tree type;
9868
9869   if (node == error_mark_node)
9870     return error_mark_node;
9871
9872   type = build_type_variant (TREE_TYPE (node),
9873                              TREE_READONLY (node),
9874                              TREE_THIS_VOLATILE (node));
9875   item = build1 (ADDR_EXPR,
9876                  build_pointer_type (type), node);
9877   if (TREE_SIDE_EFFECTS (node))
9878     TREE_SIDE_EFFECTS (item) = 1;
9879   if (staticp (node))
9880     TREE_CONSTANT (item) = 1;
9881   return fold (item);
9882 }
9883 #endif
9884
9885 /* Essentially does a "fold (build (code, type, node1, node2))" while
9886    checking for certain housekeeping things.  */
9887
9888 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9889 tree
9890 ffecom_2 (enum tree_code code, tree type, tree node1,
9891           tree node2)
9892 {
9893   tree item;
9894
9895   if ((node1 == error_mark_node)
9896       || (node2 == error_mark_node)
9897       || (type == error_mark_node))
9898     return error_mark_node;
9899
9900   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9901     {
9902       tree a, b, c, d, realtype;
9903
9904     case CONJ_EXPR:
9905       assert ("no CONJ_EXPR support yet" == NULL);
9906       return error_mark_node;
9907
9908     case COMPLEX_EXPR:
9909       item = build_tree_list (TYPE_FIELDS (type), node1);
9910       TREE_CHAIN (item) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), node2);
9911       item = build (CONSTRUCTOR, type, NULL_TREE, item);
9912       break;
9913
9914     case PLUS_EXPR:
9915       if (TREE_CODE (type) != RECORD_TYPE)
9916         {
9917           item = build (code, type, node1, node2);
9918           break;
9919         }
9920       node1 = ffecom_stabilize_aggregate_ (node1);
9921       node2 = ffecom_stabilize_aggregate_ (node2);
9922       realtype = TREE_TYPE (TYPE_FIELDS (type));
9923       item =
9924         ffecom_2 (COMPLEX_EXPR, type,
9925                   ffecom_2 (PLUS_EXPR, realtype,
9926                             ffecom_1 (REALPART_EXPR, realtype,
9927                                       node1),
9928                             ffecom_1 (REALPART_EXPR, realtype,
9929                                       node2)),
9930                   ffecom_2 (PLUS_EXPR, realtype,
9931                             ffecom_1 (IMAGPART_EXPR, realtype,
9932                                       node1),
9933                             ffecom_1 (IMAGPART_EXPR, realtype,
9934                                       node2)));
9935       break;
9936
9937     case MINUS_EXPR:
9938       if (TREE_CODE (type) != RECORD_TYPE)
9939         {
9940           item = build (code, type, node1, node2);
9941           break;
9942         }
9943       node1 = ffecom_stabilize_aggregate_ (node1);
9944       node2 = ffecom_stabilize_aggregate_ (node2);
9945       realtype = TREE_TYPE (TYPE_FIELDS (type));
9946       item =
9947         ffecom_2 (COMPLEX_EXPR, type,
9948                   ffecom_2 (MINUS_EXPR, realtype,
9949                             ffecom_1 (REALPART_EXPR, realtype,
9950                                       node1),
9951                             ffecom_1 (REALPART_EXPR, realtype,
9952                                       node2)),
9953                   ffecom_2 (MINUS_EXPR, realtype,
9954                             ffecom_1 (IMAGPART_EXPR, realtype,
9955                                       node1),
9956                             ffecom_1 (IMAGPART_EXPR, realtype,
9957                                       node2)));
9958       break;
9959
9960     case MULT_EXPR:
9961       if (TREE_CODE (type) != RECORD_TYPE)
9962         {
9963           item = build (code, type, node1, node2);
9964           break;
9965         }
9966       node1 = ffecom_stabilize_aggregate_ (node1);
9967       node2 = ffecom_stabilize_aggregate_ (node2);
9968       realtype = TREE_TYPE (TYPE_FIELDS (type));
9969       a = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9970                                node1));
9971       b = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9972                                node1));
9973       c = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9974                                node2));
9975       d = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9976                                node2));
9977       item =
9978         ffecom_2 (COMPLEX_EXPR, type,
9979                   ffecom_2 (MINUS_EXPR, realtype,
9980                             ffecom_2 (MULT_EXPR, realtype,
9981                                       a,
9982                                       c),
9983                             ffecom_2 (MULT_EXPR, realtype,
9984                                       b,
9985                                       d)),
9986                   ffecom_2 (PLUS_EXPR, realtype,
9987                             ffecom_2 (MULT_EXPR, realtype,
9988                                       a,
9989                                       d),
9990                             ffecom_2 (MULT_EXPR, realtype,
9991                                       c,
9992                                       b)));
9993       break;
9994
9995     case EQ_EXPR:
9996       if ((TREE_CODE (node1) != RECORD_TYPE)
9997           && (TREE_CODE (node2) != RECORD_TYPE))
9998         {
9999           item = build (code, type, node1, node2);
10000           break;
10001         }
10002       assert (TREE_CODE (node1) == RECORD_TYPE);
10003       assert (TREE_CODE (node2) == RECORD_TYPE);
10004       node1 = ffecom_stabilize_aggregate_ (node1);
10005       node2 = ffecom_stabilize_aggregate_ (node2);
10006       realtype = TREE_TYPE (TYPE_FIELDS (type));
10007       item =
10008         ffecom_2 (TRUTH_ANDIF_EXPR, type,
10009                   ffecom_2 (code, type,
10010                             ffecom_1 (REALPART_EXPR, realtype,
10011                                       node1),
10012                             ffecom_1 (REALPART_EXPR, realtype,
10013                                       node2)),
10014                   ffecom_2 (code, type,
10015                             ffecom_1 (IMAGPART_EXPR, realtype,
10016                                       node1),
10017                             ffecom_1 (IMAGPART_EXPR, realtype,
10018                                       node2)));
10019       break;
10020
10021     case NE_EXPR:
10022       if ((TREE_CODE (node1) != RECORD_TYPE)
10023           && (TREE_CODE (node2) != RECORD_TYPE))
10024         {
10025           item = build (code, type, node1, node2);
10026           break;
10027         }
10028       assert (TREE_CODE (node1) == RECORD_TYPE);
10029       assert (TREE_CODE (node2) == RECORD_TYPE);
10030       node1 = ffecom_stabilize_aggregate_ (node1);
10031       node2 = ffecom_stabilize_aggregate_ (node2);
10032       realtype = TREE_TYPE (TYPE_FIELDS (type));
10033       item =
10034         ffecom_2 (TRUTH_ORIF_EXPR, type,
10035                   ffecom_2 (code, type,
10036                             ffecom_1 (REALPART_EXPR, realtype,
10037                                       node1),
10038                             ffecom_1 (REALPART_EXPR, realtype,
10039                                       node2)),
10040                   ffecom_2 (code, type,
10041                             ffecom_1 (IMAGPART_EXPR, realtype,
10042                                       node1),
10043                             ffecom_1 (IMAGPART_EXPR, realtype,
10044                                       node2)));
10045       break;
10046
10047     default:
10048       item = build (code, type, node1, node2);
10049       break;
10050     }
10051
10052   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2))
10053     TREE_SIDE_EFFECTS (item) = 1;
10054   return fold (item);
10055 }
10056
10057 #endif
10058 /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
10059
10060    ffesymbol s;  // the ENTRY point itself
10061    if (ffecom_2pass_advise_entrypoint(s))
10062        // the ENTRY point has been accepted
10063
10064    Does whatever compiler needs to do when it learns about the entrypoint,
10065    like determine the return type of the master function, count the
10066    number of entrypoints, etc.  Returns FALSE if the return type is
10067    not compatible with the return type(s) of other entrypoint(s).
10068
10069    NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
10070    later (after _finish_progunit) be called with the same entrypoint(s)
10071    as passed to this fn for which TRUE was returned.
10072
10073    03-Jan-92  JCB  2.0
10074       Return FALSE if the return type conflicts with previous entrypoints.  */
10075
10076 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10077 bool
10078 ffecom_2pass_advise_entrypoint (ffesymbol entry)
10079 {
10080   ffebld list;                  /* opITEM. */
10081   ffebld mlist;                 /* opITEM. */
10082   ffebld plist;                 /* opITEM. */
10083   ffebld arg;                   /* ffebld_head(opITEM). */
10084   ffebld item;                  /* opITEM. */
10085   ffesymbol s;                  /* ffebld_symter(arg). */
10086   ffeinfoBasictype bt = ffesymbol_basictype (entry);
10087   ffeinfoKindtype kt = ffesymbol_kindtype (entry);
10088   ffetargetCharacterSize size = ffesymbol_size (entry);
10089   bool ok;
10090
10091   if (ffecom_num_entrypoints_ == 0)
10092     {                           /* First entrypoint, make list of main
10093                                    arglist's dummies. */
10094       assert (ffecom_primary_entry_ != NULL);
10095
10096       ffecom_master_bt_ = ffesymbol_basictype (ffecom_primary_entry_);
10097       ffecom_master_kt_ = ffesymbol_kindtype (ffecom_primary_entry_);
10098       ffecom_master_size_ = ffesymbol_size (ffecom_primary_entry_);
10099
10100       for (plist = NULL, list = ffesymbol_dummyargs (ffecom_primary_entry_);
10101            list != NULL;
10102            list = ffebld_trail (list))
10103         {
10104           arg = ffebld_head (list);
10105           if (ffebld_op (arg) != FFEBLD_opSYMTER)
10106             continue;           /* Alternate return or some such thing. */
10107           item = ffebld_new_item (arg, NULL);
10108           if (plist == NULL)
10109             ffecom_master_arglist_ = item;
10110           else
10111             ffebld_set_trail (plist, item);
10112           plist = item;
10113         }
10114     }
10115
10116   /* If necessary, scan entry arglist for alternate returns.  Do this scan
10117      apparently redundantly (it's done below to UNIONize the arglists) so
10118      that we don't complain about RETURN 1 if an offending ENTRY is the only
10119      one with an alternate return.  */
10120
10121   if (!ffecom_is_altreturning_)
10122     {
10123       for (list = ffesymbol_dummyargs (entry);
10124            list != NULL;
10125            list = ffebld_trail (list))
10126         {
10127           arg = ffebld_head (list);
10128           if (ffebld_op (arg) == FFEBLD_opSTAR)
10129             {
10130               ffecom_is_altreturning_ = TRUE;
10131               break;
10132             }
10133         }
10134     }
10135
10136   /* Now check type compatibility. */
10137
10138   switch (ffecom_master_bt_)
10139     {
10140     case FFEINFO_basictypeNONE:
10141       ok = (bt != FFEINFO_basictypeCHARACTER);
10142       break;
10143
10144     case FFEINFO_basictypeCHARACTER:
10145       ok
10146         = (bt == FFEINFO_basictypeCHARACTER)
10147         && (kt == ffecom_master_kt_)
10148         && (size == ffecom_master_size_);
10149       break;
10150
10151     case FFEINFO_basictypeANY:
10152       return FALSE;             /* Just don't bother. */
10153
10154     default:
10155       if (bt == FFEINFO_basictypeCHARACTER)
10156         {
10157           ok = FALSE;
10158           break;
10159         }
10160       ok = TRUE;
10161       if ((bt != ffecom_master_bt_) || (kt != ffecom_master_kt_))
10162         {
10163           ffecom_master_bt_ = FFEINFO_basictypeNONE;
10164           ffecom_master_kt_ = FFEINFO_kindtypeNONE;
10165         }
10166       break;
10167     }
10168
10169   if (!ok)
10170     {
10171       ffebad_start (FFEBAD_ENTRY_CONFLICTS);
10172       ffest_ffebad_here_current_stmt (0);
10173       ffebad_finish ();
10174       return FALSE;             /* Can't handle entrypoint. */
10175     }
10176
10177   /* Entrypoint type compatible with previous types. */
10178
10179   ++ffecom_num_entrypoints_;
10180
10181   /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
10182
10183   for (list = ffesymbol_dummyargs (entry);
10184        list != NULL;
10185        list = ffebld_trail (list))
10186     {
10187       arg = ffebld_head (list);
10188       if (ffebld_op (arg) != FFEBLD_opSYMTER)
10189         continue;               /* Alternate return or some such thing. */
10190       s = ffebld_symter (arg);
10191       for (plist = NULL, mlist = ffecom_master_arglist_;
10192            mlist != NULL;
10193            plist = mlist, mlist = ffebld_trail (mlist))
10194         {                       /* plist points to previous item for easy
10195                                    appending of arg. */
10196           if (ffebld_symter (ffebld_head (mlist)) == s)
10197             break;              /* Already have this arg in the master list. */
10198         }
10199       if (mlist != NULL)
10200         continue;               /* Already have this arg in the master list. */
10201
10202       /* Append this arg to the master list. */
10203
10204       item = ffebld_new_item (arg, NULL);
10205       if (plist == NULL)
10206         ffecom_master_arglist_ = item;
10207       else
10208         ffebld_set_trail (plist, item);
10209     }
10210
10211   return TRUE;
10212 }
10213
10214 #endif
10215 /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
10216
10217    ffesymbol s;  // the ENTRY point itself
10218    ffecom_2pass_do_entrypoint(s);
10219
10220    Does whatever compiler needs to do to make the entrypoint actually
10221    happen.  Must be called for each entrypoint after
10222    ffecom_finish_progunit is called.  */
10223
10224 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10225 void
10226 ffecom_2pass_do_entrypoint (ffesymbol entry)
10227 {
10228   static int mfn_num = 0;
10229   static int ent_num;
10230
10231   if (mfn_num != ffecom_num_fns_)
10232     {                           /* First entrypoint for this program unit. */
10233       ent_num = 1;
10234       mfn_num = ffecom_num_fns_;
10235       ffecom_do_entry_ (ffecom_primary_entry_, 0);
10236     }
10237   else
10238     ++ent_num;
10239
10240   --ffecom_num_entrypoints_;
10241
10242   ffecom_do_entry_ (entry, ent_num);
10243 }
10244
10245 #endif
10246
10247 /* Essentially does a "fold (build (code, type, node1, node2))" while
10248    checking for certain housekeeping things.  Always sets
10249    TREE_SIDE_EFFECTS.  */
10250
10251 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10252 tree
10253 ffecom_2s (enum tree_code code, tree type, tree node1,
10254            tree node2)
10255 {
10256   tree item;
10257
10258   if ((node1 == error_mark_node)
10259       || (node2 == error_mark_node)
10260       || (type == error_mark_node))
10261     return error_mark_node;
10262
10263   item = build (code, type, node1, node2);
10264   TREE_SIDE_EFFECTS (item) = 1;
10265   return fold (item);
10266 }
10267
10268 #endif
10269 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10270    checking for certain housekeeping things.  */
10271
10272 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10273 tree
10274 ffecom_3 (enum tree_code code, tree type, tree node1,
10275           tree node2, tree node3)
10276 {
10277   tree item;
10278
10279   if ((node1 == error_mark_node)
10280       || (node2 == error_mark_node)
10281       || (node3 == error_mark_node)
10282       || (type == error_mark_node))
10283     return error_mark_node;
10284
10285   item = build (code, type, node1, node2, node3);
10286   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2)
10287       || (node3 != NULL_TREE && TREE_SIDE_EFFECTS (node3)))
10288     TREE_SIDE_EFFECTS (item) = 1;
10289   return fold (item);
10290 }
10291
10292 #endif
10293 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10294    checking for certain housekeeping things.  Always sets
10295    TREE_SIDE_EFFECTS.  */
10296
10297 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10298 tree
10299 ffecom_3s (enum tree_code code, tree type, tree node1,
10300            tree node2, tree node3)
10301 {
10302   tree item;
10303
10304   if ((node1 == error_mark_node)
10305       || (node2 == error_mark_node)
10306       || (node3 == error_mark_node)
10307       || (type == error_mark_node))
10308     return error_mark_node;
10309
10310   item = build (code, type, node1, node2, node3);
10311   TREE_SIDE_EFFECTS (item) = 1;
10312   return fold (item);
10313 }
10314
10315 #endif
10316
10317 /* ffecom_arg_expr -- Transform argument expr into gcc tree
10318
10319    See use by ffecom_list_expr.
10320
10321    If expression is NULL, returns an integer zero tree.  If it is not
10322    a CHARACTER expression, returns whatever ffecom_expr
10323    returns and sets the length return value to NULL_TREE.  Otherwise
10324    generates code to evaluate the character expression, returns the proper
10325    pointer to the result, but does NOT set the length return value to a tree
10326    that specifies the length of the result.  (In other words, the length
10327    variable is always set to NULL_TREE, because a length is never passed.)
10328
10329    21-Dec-91  JCB  1.1
10330       Don't set returned length, since nobody needs it (yet; someday if
10331       we allow CHARACTER*(*) dummies to statement functions, we'll need
10332       it).  */
10333
10334 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10335 tree
10336 ffecom_arg_expr (ffebld expr, tree *length)
10337 {
10338   tree ign;
10339
10340   *length = NULL_TREE;
10341
10342   if (expr == NULL)
10343     return integer_zero_node;
10344
10345   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10346     return ffecom_expr (expr);
10347
10348   return ffecom_arg_ptr_to_expr (expr, &ign);
10349 }
10350
10351 #endif
10352 /* Transform expression into constant argument-pointer-to-expression tree.
10353
10354    If the expression can be transformed into a argument-pointer-to-expression
10355    tree that is constant, that is done, and the tree returned.  Else
10356    NULL_TREE is returned.
10357
10358    That way, a caller can attempt to provide compile-time initialization
10359    of a variable and, if that fails, *then* choose to start a new block
10360    and resort to using temporaries, as appropriate.  */
10361
10362 tree
10363 ffecom_arg_ptr_to_const_expr (ffebld expr, tree *length)
10364 {
10365   if (! expr)
10366     return integer_zero_node;
10367
10368   if (ffebld_op (expr) == FFEBLD_opANY)
10369     {
10370       if (length)
10371         *length = error_mark_node;
10372       return error_mark_node;
10373     }
10374
10375   if (ffebld_arity (expr) == 0
10376       && (ffebld_op (expr) != FFEBLD_opSYMTER
10377           || ffebld_where (expr) == FFEINFO_whereCOMMON
10378           || ffebld_where (expr) == FFEINFO_whereGLOBAL
10379           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10380     {
10381       tree t;
10382
10383       t = ffecom_arg_ptr_to_expr (expr, length);
10384       assert (TREE_CONSTANT (t));
10385       assert (! length || TREE_CONSTANT (*length));
10386       return t;
10387     }
10388
10389   if (length
10390       && ffebld_size (expr) != FFETARGET_charactersizeNONE)
10391     *length = build_int_2 (ffebld_size (expr), 0);
10392   else if (length)
10393     *length = NULL_TREE;
10394   return NULL_TREE;
10395 }
10396
10397 /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
10398
10399    See use by ffecom_list_ptr_to_expr.
10400
10401    If expression is NULL, returns an integer zero tree.  If it is not
10402    a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10403    returns and sets the length return value to NULL_TREE.  Otherwise
10404    generates code to evaluate the character expression, returns the proper
10405    pointer to the result, AND sets the length return value to a tree that
10406    specifies the length of the result.
10407
10408    If the length argument is NULL, this is a slightly special
10409    case of building a FORMAT expression, that is, an expression that
10410    will be used at run time without regard to length.  For the current
10411    implementation, which uses the libf2c library, this means it is nice
10412    to append a null byte to the end of the expression, where feasible,
10413    to make sure any diagnostic about the FORMAT string terminates at
10414    some useful point.
10415
10416    For now, treat %REF(char-expr) as the same as char-expr with a NULL
10417    length argument.  This might even be seen as a feature, if a null
10418    byte can always be appended.  */
10419
10420 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10421 tree
10422 ffecom_arg_ptr_to_expr (ffebld expr, tree *length)
10423 {
10424   tree item;
10425   tree ign_length;
10426   ffecomConcatList_ catlist;
10427
10428   if (length != NULL)
10429     *length = NULL_TREE;
10430
10431   if (expr == NULL)
10432     return integer_zero_node;
10433
10434   switch (ffebld_op (expr))
10435     {
10436     case FFEBLD_opPERCENT_VAL:
10437       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10438         return ffecom_expr (ffebld_left (expr));
10439       {
10440         tree temp_exp;
10441         tree temp_length;
10442
10443         temp_exp = ffecom_arg_ptr_to_expr (ffebld_left (expr), &temp_length);
10444         if (temp_exp == error_mark_node)
10445           return error_mark_node;
10446
10447         return ffecom_1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (temp_exp)),
10448                          temp_exp);
10449       }
10450
10451     case FFEBLD_opPERCENT_REF:
10452       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10453         return ffecom_ptr_to_expr (ffebld_left (expr));
10454       if (length != NULL)
10455         {
10456           ign_length = NULL_TREE;
10457           length = &ign_length;
10458         }
10459       expr = ffebld_left (expr);
10460       break;
10461
10462     case FFEBLD_opPERCENT_DESCR:
10463       switch (ffeinfo_basictype (ffebld_info (expr)))
10464         {
10465 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10466         case FFEINFO_basictypeHOLLERITH:
10467 #endif
10468         case FFEINFO_basictypeCHARACTER:
10469           break;                /* Passed by descriptor anyway. */
10470
10471         default:
10472           item = ffecom_ptr_to_expr (expr);
10473           if (item != error_mark_node)
10474             *length = TYPE_SIZE (TREE_TYPE (TREE_TYPE (item)));
10475           break;
10476         }
10477       break;
10478
10479     default:
10480       break;
10481     }
10482
10483 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10484   if ((ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeHOLLERITH)
10485       && (length != NULL))
10486     {                           /* Pass Hollerith by descriptor. */
10487       ffetargetHollerith h;
10488
10489       assert (ffebld_op (expr) == FFEBLD_opCONTER);
10490       h = ffebld_cu_val_hollerith (ffebld_constant_union
10491                                    (ffebld_conter (expr)));
10492       *length
10493         = build_int_2 (h.length, 0);
10494       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10495     }
10496 #endif
10497
10498   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10499     return ffecom_ptr_to_expr (expr);
10500
10501   assert (ffeinfo_kindtype (ffebld_info (expr))
10502           == FFEINFO_kindtypeCHARACTER1);
10503
10504   while (ffebld_op (expr) == FFEBLD_opPAREN)
10505     expr = ffebld_left (expr);
10506
10507   catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
10508   switch (ffecom_concat_list_count_ (catlist))
10509     {
10510     case 0:                     /* Shouldn't happen, but in case it does... */
10511       if (length != NULL)
10512         {
10513           *length = ffecom_f2c_ftnlen_zero_node;
10514           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10515         }
10516       ffecom_concat_list_kill_ (catlist);
10517       return null_pointer_node;
10518
10519     case 1:                     /* The (fairly) easy case. */
10520       if (length == NULL)
10521         ffecom_char_args_with_null_ (&item, &ign_length,
10522                                      ffecom_concat_list_expr_ (catlist, 0));
10523       else
10524         ffecom_char_args_ (&item, length,
10525                            ffecom_concat_list_expr_ (catlist, 0));
10526       ffecom_concat_list_kill_ (catlist);
10527       assert (item != NULL_TREE);
10528       return item;
10529
10530     default:                    /* Must actually concatenate things. */
10531       break;
10532     }
10533
10534   {
10535     int count = ffecom_concat_list_count_ (catlist);
10536     int i;
10537     tree lengths;
10538     tree items;
10539     tree length_array;
10540     tree item_array;
10541     tree citem;
10542     tree clength;
10543     tree temporary;
10544     tree num;
10545     tree known_length;
10546     ffetargetCharacterSize sz;
10547
10548     sz = ffecom_concat_list_maxlen_ (catlist);
10549     /* ~~Kludge! */
10550     assert (sz != FFETARGET_charactersizeNONE);
10551
10552 #ifdef HOHO
10553     length_array
10554       = lengths
10555       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
10556                              FFETARGET_charactersizeNONE, count, TRUE);
10557     item_array
10558       = items
10559       = ffecom_push_tempvar (ffecom_f2c_address_type_node,
10560                              FFETARGET_charactersizeNONE, count, TRUE);
10561     temporary = ffecom_push_tempvar (char_type_node,
10562                                      sz, -1, TRUE);
10563 #else
10564     {
10565       tree hook;
10566
10567       hook = ffebld_nonter_hook (expr);
10568       assert (hook);
10569       assert (TREE_CODE (hook) == TREE_VEC);
10570       assert (TREE_VEC_LENGTH (hook) == 3);
10571       length_array = lengths = TREE_VEC_ELT (hook, 0);
10572       item_array = items = TREE_VEC_ELT (hook, 1);
10573       temporary = TREE_VEC_ELT (hook, 2);
10574     }
10575 #endif
10576
10577     known_length = ffecom_f2c_ftnlen_zero_node;
10578
10579     for (i = 0; i < count; ++i)
10580       {
10581         if ((i == count)
10582             && (length == NULL))
10583           ffecom_char_args_with_null_ (&citem, &clength,
10584                                        ffecom_concat_list_expr_ (catlist, i));
10585         else
10586           ffecom_char_args_ (&citem, &clength,
10587                              ffecom_concat_list_expr_ (catlist, i));
10588         if ((citem == error_mark_node)
10589             || (clength == error_mark_node))
10590           {
10591             ffecom_concat_list_kill_ (catlist);
10592             *length = error_mark_node;
10593             return error_mark_node;
10594           }
10595
10596         items
10597           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
10598                       ffecom_modify (void_type_node,
10599                                      ffecom_2 (ARRAY_REF,
10600                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
10601                                                item_array,
10602                                                build_int_2 (i, 0)),
10603                                      citem),
10604                       items);
10605         clength = ffecom_save_tree (clength);
10606         if (length != NULL)
10607           known_length
10608             = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
10609                         known_length,
10610                         clength);
10611         lengths
10612           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
10613                       ffecom_modify (void_type_node,
10614                                      ffecom_2 (ARRAY_REF,
10615                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
10616                                                length_array,
10617                                                build_int_2 (i, 0)),
10618                                      clength),
10619                       lengths);
10620       }
10621
10622     temporary = ffecom_1 (ADDR_EXPR,
10623                           build_pointer_type (TREE_TYPE (temporary)),
10624                           temporary);
10625
10626     item = build_tree_list (NULL_TREE, temporary);
10627     TREE_CHAIN (item)
10628       = build_tree_list (NULL_TREE,
10629                          ffecom_1 (ADDR_EXPR,
10630                                    build_pointer_type (TREE_TYPE (items)),
10631                                    items));
10632     TREE_CHAIN (TREE_CHAIN (item))
10633       = build_tree_list (NULL_TREE,
10634                          ffecom_1 (ADDR_EXPR,
10635                                    build_pointer_type (TREE_TYPE (lengths)),
10636                                    lengths));
10637     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
10638       = build_tree_list
10639         (NULL_TREE,
10640          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
10641                    convert (ffecom_f2c_ftnlen_type_node,
10642                             build_int_2 (count, 0))));
10643     num = build_int_2 (sz, 0);
10644     TREE_TYPE (num) = ffecom_f2c_ftnlen_type_node;
10645     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item))))
10646       = build_tree_list (NULL_TREE, num);
10647
10648     item = ffecom_call_gfrt (FFECOM_gfrtCAT, item, NULL_TREE);
10649     TREE_SIDE_EFFECTS (item) = 1;
10650     item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (temporary),
10651                      item,
10652                      temporary);
10653
10654     if (length != NULL)
10655       *length = known_length;
10656   }
10657
10658   ffecom_concat_list_kill_ (catlist);
10659   assert (item != NULL_TREE);
10660   return item;
10661 }
10662
10663 #endif
10664 /* Generate call to run-time function.
10665
10666    The first arg is the GNU Fortran Run-Time function index, the second
10667    arg is the list of arguments to pass to it.  Returned is the expression
10668    (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
10669    result (which may be void).  */
10670
10671 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10672 tree
10673 ffecom_call_gfrt (ffecomGfrt ix, tree args, tree hook)
10674 {
10675   return ffecom_call_ (ffecom_gfrt_tree_ (ix),
10676                        ffecom_gfrt_kindtype (ix),
10677                        ffe_is_f2c_library () && ffecom_gfrt_complex_[ix],
10678                        NULL_TREE, args, NULL_TREE, NULL,
10679                        NULL, NULL_TREE, TRUE, hook);
10680 }
10681 #endif
10682
10683 /* Transform constant-union to tree.  */
10684
10685 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10686 tree
10687 ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt,
10688                       ffeinfoKindtype kt, tree tree_type)
10689 {
10690   tree item;
10691
10692   switch (bt)
10693     {
10694     case FFEINFO_basictypeINTEGER:
10695       {
10696         int val;
10697
10698         switch (kt)
10699           {
10700 #if FFETARGET_okINTEGER1
10701           case FFEINFO_kindtypeINTEGER1:
10702             val = ffebld_cu_val_integer1 (*cu);
10703             break;
10704 #endif
10705
10706 #if FFETARGET_okINTEGER2
10707           case FFEINFO_kindtypeINTEGER2:
10708             val = ffebld_cu_val_integer2 (*cu);
10709             break;
10710 #endif
10711
10712 #if FFETARGET_okINTEGER3
10713           case FFEINFO_kindtypeINTEGER3:
10714             val = ffebld_cu_val_integer3 (*cu);
10715             break;
10716 #endif
10717
10718 #if FFETARGET_okINTEGER4
10719           case FFEINFO_kindtypeINTEGER4:
10720             val = ffebld_cu_val_integer4 (*cu);
10721             break;
10722 #endif
10723
10724           default:
10725             assert ("bad INTEGER constant kind type" == NULL);
10726             /* Fall through. */
10727           case FFEINFO_kindtypeANY:
10728             return error_mark_node;
10729           }
10730         item = build_int_2 (val, (val < 0) ? -1 : 0);
10731         TREE_TYPE (item) = tree_type;
10732       }
10733       break;
10734
10735     case FFEINFO_basictypeLOGICAL:
10736       {
10737         int val;
10738
10739         switch (kt)
10740           {
10741 #if FFETARGET_okLOGICAL1
10742           case FFEINFO_kindtypeLOGICAL1:
10743             val = ffebld_cu_val_logical1 (*cu);
10744             break;
10745 #endif
10746
10747 #if FFETARGET_okLOGICAL2
10748           case FFEINFO_kindtypeLOGICAL2:
10749             val = ffebld_cu_val_logical2 (*cu);
10750             break;
10751 #endif
10752
10753 #if FFETARGET_okLOGICAL3
10754           case FFEINFO_kindtypeLOGICAL3:
10755             val = ffebld_cu_val_logical3 (*cu);
10756             break;
10757 #endif
10758
10759 #if FFETARGET_okLOGICAL4
10760           case FFEINFO_kindtypeLOGICAL4:
10761             val = ffebld_cu_val_logical4 (*cu);
10762             break;
10763 #endif
10764
10765           default:
10766             assert ("bad LOGICAL constant kind type" == NULL);
10767             /* Fall through. */
10768           case FFEINFO_kindtypeANY:
10769             return error_mark_node;
10770           }
10771         item = build_int_2 (val, (val < 0) ? -1 : 0);
10772         TREE_TYPE (item) = tree_type;
10773       }
10774       break;
10775
10776     case FFEINFO_basictypeREAL:
10777       {
10778         REAL_VALUE_TYPE val;
10779
10780         switch (kt)
10781           {
10782 #if FFETARGET_okREAL1
10783           case FFEINFO_kindtypeREAL1:
10784             val = ffetarget_value_real1 (ffebld_cu_val_real1 (*cu));
10785             break;
10786 #endif
10787
10788 #if FFETARGET_okREAL2
10789           case FFEINFO_kindtypeREAL2:
10790             val = ffetarget_value_real2 (ffebld_cu_val_real2 (*cu));
10791             break;
10792 #endif
10793
10794 #if FFETARGET_okREAL3
10795           case FFEINFO_kindtypeREAL3:
10796             val = ffetarget_value_real3 (ffebld_cu_val_real3 (*cu));
10797             break;
10798 #endif
10799
10800 #if FFETARGET_okREAL4
10801           case FFEINFO_kindtypeREAL4:
10802             val = ffetarget_value_real4 (ffebld_cu_val_real4 (*cu));
10803             break;
10804 #endif
10805
10806           default:
10807             assert ("bad REAL constant kind type" == NULL);
10808             /* Fall through. */
10809           case FFEINFO_kindtypeANY:
10810             return error_mark_node;
10811           }
10812         item = build_real (tree_type, val);
10813       }
10814       break;
10815
10816     case FFEINFO_basictypeCOMPLEX:
10817       {
10818         REAL_VALUE_TYPE real;
10819         REAL_VALUE_TYPE imag;
10820         tree el_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
10821
10822         switch (kt)
10823           {
10824 #if FFETARGET_okCOMPLEX1
10825           case FFEINFO_kindtypeREAL1:
10826             real = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).real);
10827             imag = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).imaginary);
10828             break;
10829 #endif
10830
10831 #if FFETARGET_okCOMPLEX2
10832           case FFEINFO_kindtypeREAL2:
10833             real = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).real);
10834             imag = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).imaginary);
10835             break;
10836 #endif
10837
10838 #if FFETARGET_okCOMPLEX3
10839           case FFEINFO_kindtypeREAL3:
10840             real = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).real);
10841             imag = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).imaginary);
10842             break;
10843 #endif
10844
10845 #if FFETARGET_okCOMPLEX4
10846           case FFEINFO_kindtypeREAL4:
10847             real = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).real);
10848             imag = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).imaginary);
10849             break;
10850 #endif
10851
10852           default:
10853             assert ("bad REAL constant kind type" == NULL);
10854             /* Fall through. */
10855           case FFEINFO_kindtypeANY:
10856             return error_mark_node;
10857           }
10858         item = ffecom_build_complex_constant_ (tree_type,
10859                                                build_real (el_type, real),
10860                                                build_real (el_type, imag));
10861       }
10862       break;
10863
10864     case FFEINFO_basictypeCHARACTER:
10865       {                         /* Happens only in DATA and similar contexts. */
10866         ffetargetCharacter1 val;
10867
10868         switch (kt)
10869           {
10870 #if FFETARGET_okCHARACTER1
10871           case FFEINFO_kindtypeLOGICAL1:
10872             val = ffebld_cu_val_character1 (*cu);
10873             break;
10874 #endif
10875
10876           default:
10877             assert ("bad CHARACTER constant kind type" == NULL);
10878             /* Fall through. */
10879           case FFEINFO_kindtypeANY:
10880             return error_mark_node;
10881           }
10882         item = build_string (ffetarget_length_character1 (val),
10883                              ffetarget_text_character1 (val));
10884         TREE_TYPE (item)
10885           = build_type_variant (build_array_type (char_type_node,
10886                                                   build_range_type
10887                                                   (integer_type_node,
10888                                                    integer_one_node,
10889                                                    build_int_2
10890                                                 (ffetarget_length_character1
10891                                                  (val), 0))),
10892                                 1, 0);
10893       }
10894       break;
10895
10896     case FFEINFO_basictypeHOLLERITH:
10897       {
10898         ffetargetHollerith h;
10899
10900         h = ffebld_cu_val_hollerith (*cu);
10901
10902         /* If not at least as wide as default INTEGER, widen it.  */
10903         if (h.length >= FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE)
10904           item = build_string (h.length, h.text);
10905         else
10906           {
10907             char str[FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE];
10908
10909             memcpy (str, h.text, h.length);
10910             memset (&str[h.length], ' ',
10911                     FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE
10912                     - h.length);
10913             item = build_string (FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE,
10914                                  str);
10915           }
10916         TREE_TYPE (item)
10917           = build_type_variant (build_array_type (char_type_node,
10918                                                   build_range_type
10919                                                   (integer_type_node,
10920                                                    integer_one_node,
10921                                                    build_int_2
10922                                                    (h.length, 0))),
10923                                 1, 0);
10924       }
10925       break;
10926
10927     case FFEINFO_basictypeTYPELESS:
10928       {
10929         ffetargetInteger1 ival;
10930         ffetargetTypeless tless;
10931         ffebad error;
10932
10933         tless = ffebld_cu_val_typeless (*cu);
10934         error = ffetarget_convert_integer1_typeless (&ival, tless);
10935         assert (error == FFEBAD);
10936
10937         item = build_int_2 ((int) ival, 0);
10938       }
10939       break;
10940
10941     default:
10942       assert ("not yet on constant type" == NULL);
10943       /* Fall through. */
10944     case FFEINFO_basictypeANY:
10945       return error_mark_node;
10946     }
10947
10948   TREE_CONSTANT (item) = 1;
10949
10950   return item;
10951 }
10952
10953 #endif
10954
10955 /* Transform expression into constant tree.
10956
10957    If the expression can be transformed into a tree that is constant,
10958    that is done, and the tree returned.  Else NULL_TREE is returned.
10959
10960    That way, a caller can attempt to provide compile-time initialization
10961    of a variable and, if that fails, *then* choose to start a new block
10962    and resort to using temporaries, as appropriate.  */
10963
10964 tree
10965 ffecom_const_expr (ffebld expr)
10966 {
10967   if (! expr)
10968     return integer_zero_node;
10969
10970   if (ffebld_op (expr) == FFEBLD_opANY)
10971     return error_mark_node;
10972
10973   if (ffebld_arity (expr) == 0
10974       && (ffebld_op (expr) != FFEBLD_opSYMTER
10975 #if NEWCOMMON
10976           /* ~~Enable once common/equivalence is handled properly?  */
10977           || ffebld_where (expr) == FFEINFO_whereCOMMON
10978 #endif
10979           || ffebld_where (expr) == FFEINFO_whereGLOBAL
10980           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10981     {
10982       tree t;
10983
10984       t = ffecom_expr (expr);
10985       assert (TREE_CONSTANT (t));
10986       return t;
10987     }
10988
10989   return NULL_TREE;
10990 }
10991
10992 /* Handy way to make a field in a struct/union.  */
10993
10994 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10995 tree
10996 ffecom_decl_field (tree context, tree prevfield,
10997                    const char *name, tree type)
10998 {
10999   tree field;
11000
11001   field = build_decl (FIELD_DECL, get_identifier (name), type);
11002   DECL_CONTEXT (field) = context;
11003   DECL_FRAME_SIZE (field) = 0;
11004   if (prevfield != NULL_TREE)
11005     TREE_CHAIN (prevfield) = field;
11006
11007   return field;
11008 }
11009
11010 #endif
11011
11012 void
11013 ffecom_close_include (FILE *f)
11014 {
11015 #if FFECOM_GCC_INCLUDE
11016   ffecom_close_include_ (f);
11017 #endif
11018 }
11019
11020 int
11021 ffecom_decode_include_option (char *spec)
11022 {
11023 #if FFECOM_GCC_INCLUDE
11024   return ffecom_decode_include_option_ (spec);
11025 #else
11026   return 1;
11027 #endif
11028 }
11029
11030 /* End a compound statement (block).  */
11031
11032 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11033 tree
11034 ffecom_end_compstmt (void)
11035 {
11036   return bison_rule_compstmt_ ();
11037 }
11038 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
11039
11040 /* ffecom_end_transition -- Perform end transition on all symbols
11041
11042    ffecom_end_transition();
11043
11044    Calls ffecom_sym_end_transition for each global and local symbol.  */
11045
11046 void
11047 ffecom_end_transition ()
11048 {
11049 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11050   ffebld item;
11051 #endif
11052
11053   if (ffe_is_ffedebug ())
11054     fprintf (dmpout, "; end_stmt_transition\n");
11055
11056 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11057   ffecom_list_blockdata_ = NULL;
11058   ffecom_list_common_ = NULL;
11059 #endif
11060
11061   ffesymbol_drive (ffecom_sym_end_transition);
11062   if (ffe_is_ffedebug ())
11063     {
11064       ffestorag_report ();
11065 #if FFECOM_targetCURRENT == FFECOM_targetFFE
11066       ffesymbol_report_all ();
11067 #endif
11068     }
11069
11070 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11071   ffecom_start_progunit_ ();
11072
11073   for (item = ffecom_list_blockdata_;
11074        item != NULL;
11075        item = ffebld_trail (item))
11076     {
11077       ffebld callee;
11078       ffesymbol s;
11079       tree dt;
11080       tree t;
11081       tree var;
11082       int yes;
11083       static int number = 0;
11084
11085       callee = ffebld_head (item);
11086       s = ffebld_symter (callee);
11087       t = ffesymbol_hook (s).decl_tree;
11088       if (t == NULL_TREE)
11089         {
11090           s = ffecom_sym_transform_ (s);
11091           t = ffesymbol_hook (s).decl_tree;
11092         }
11093
11094       yes = suspend_momentary ();
11095
11096       dt = build_pointer_type (TREE_TYPE (t));
11097
11098       var = build_decl (VAR_DECL,
11099                         ffecom_get_invented_identifier ("__g77_forceload_%d",
11100                                                         number++),
11101                         dt);
11102       DECL_EXTERNAL (var) = 0;
11103       TREE_STATIC (var) = 1;
11104       TREE_PUBLIC (var) = 0;
11105       DECL_INITIAL (var) = error_mark_node;
11106       TREE_USED (var) = 1;
11107
11108       var = start_decl (var, FALSE);
11109
11110       t = ffecom_1 (ADDR_EXPR, dt, t);
11111
11112       finish_decl (var, t, FALSE);
11113
11114       resume_momentary (yes);
11115     }
11116
11117   /* This handles any COMMON areas that weren't referenced but have, for
11118      example, important initial data.  */
11119
11120   for (item = ffecom_list_common_;
11121        item != NULL;
11122        item = ffebld_trail (item))
11123     ffecom_transform_common_ (ffebld_symter (ffebld_head (item)));
11124
11125   ffecom_list_common_ = NULL;
11126 #endif
11127 }
11128
11129 /* ffecom_exec_transition -- Perform exec transition on all symbols
11130
11131    ffecom_exec_transition();
11132
11133    Calls ffecom_sym_exec_transition for each global and local symbol.
11134    Make sure error updating not inhibited.  */
11135
11136 void
11137 ffecom_exec_transition ()
11138 {
11139   bool inhibited;
11140
11141   if (ffe_is_ffedebug ())
11142     fprintf (dmpout, "; exec_stmt_transition\n");
11143
11144   inhibited = ffebad_inhibit ();
11145   ffebad_set_inhibit (FALSE);
11146
11147   ffesymbol_drive (ffecom_sym_exec_transition); /* Don't retract! */
11148   ffeequiv_exec_transition ();  /* Handle all pending EQUIVALENCEs. */
11149   if (ffe_is_ffedebug ())
11150     {
11151       ffestorag_report ();
11152 #if FFECOM_targetCURRENT == FFECOM_targetFFE
11153       ffesymbol_report_all ();
11154 #endif
11155     }
11156
11157   if (inhibited)
11158     ffebad_set_inhibit (TRUE);
11159 }
11160
11161 /* Handle assignment statement.
11162
11163    Convert dest and source using ffecom_expr, then join them
11164    with an ASSIGN op and pass the whole thing to expand_expr_stmt.  */
11165
11166 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11167 void
11168 ffecom_expand_let_stmt (ffebld dest, ffebld source)
11169 {
11170   tree dest_tree;
11171   tree dest_length;
11172   tree source_tree;
11173   tree expr_tree;
11174
11175   if (ffeinfo_basictype (ffebld_info (dest)) != FFEINFO_basictypeCHARACTER)
11176     {
11177       bool dest_used;
11178       tree assign_temp;
11179
11180       /* This attempts to replicate the test below, but must not be
11181          true when the test below is false.  (Always err on the side
11182          of creating unused temporaries, to avoid ICEs.)  */
11183       if (ffebld_op (dest) != FFEBLD_opSYMTER
11184           || ((dest_tree = ffesymbol_hook (ffebld_symter (dest)).decl_tree)
11185               && (TREE_CODE (dest_tree) != VAR_DECL
11186                   || TREE_ADDRESSABLE (dest_tree))))
11187         {
11188           ffecom_prepare_expr_ (source, dest);
11189           dest_used = TRUE;
11190         }
11191       else
11192         {
11193           ffecom_prepare_expr_ (source, NULL);
11194           dest_used = FALSE;
11195         }
11196
11197       ffecom_prepare_expr_w (NULL_TREE, dest);
11198
11199       /* For COMPLEX assignment like C1=C2, if partial overlap is possible,
11200          create a temporary through which the assignment is to take place,
11201          since MODIFY_EXPR doesn't handle partial overlap properly.  */
11202       if (ffebld_basictype (dest) == FFEINFO_basictypeCOMPLEX
11203           && ffecom_possible_partial_overlap_ (dest, source))
11204         {
11205           assign_temp = ffecom_make_tempvar ("complex_let",
11206                                              ffecom_tree_type
11207                                              [ffebld_basictype (dest)]
11208                                              [ffebld_kindtype (dest)],
11209                                              FFETARGET_charactersizeNONE,
11210                                              -1);
11211         }
11212       else
11213         assign_temp = NULL_TREE;
11214
11215       ffecom_prepare_end ();
11216
11217       dest_tree = ffecom_expr_w (NULL_TREE, dest);
11218       if (dest_tree == error_mark_node)
11219         return;
11220
11221       if ((TREE_CODE (dest_tree) != VAR_DECL)
11222           || TREE_ADDRESSABLE (dest_tree))
11223         source_tree = ffecom_expr_ (source, dest_tree, dest, &dest_used,
11224                                     FALSE, FALSE);
11225       else
11226         {
11227           assert (! dest_used);
11228           dest_used = FALSE;
11229           source_tree = ffecom_expr (source);
11230         }
11231       if (source_tree == error_mark_node)
11232         return;
11233
11234       if (dest_used)
11235         expr_tree = source_tree;
11236       else if (assign_temp)
11237         {
11238 #ifdef MOVE_EXPR
11239           /* The back end understands a conceptual move (evaluate source;
11240              store into dest), so use that, in case it can determine
11241              that it is going to use, say, two registers as temporaries
11242              anyway.  So don't use the temp (and someday avoid generating
11243              it, once this code starts triggering regularly).  */
11244           expr_tree = ffecom_2s (MOVE_EXPR, void_type_node,
11245                                  dest_tree,
11246                                  source_tree);
11247 #else
11248           expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11249                                  assign_temp,
11250                                  source_tree);
11251           expand_expr_stmt (expr_tree);
11252           expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11253                                  dest_tree,
11254                                  assign_temp);
11255 #endif
11256         }
11257       else
11258         expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11259                                dest_tree,
11260                                source_tree);
11261
11262       expand_expr_stmt (expr_tree);
11263       return;
11264     }
11265
11266   ffecom_prepare_let_char_ (ffebld_size_known (dest), source);
11267   ffecom_prepare_expr_w (NULL_TREE, dest);
11268
11269   ffecom_prepare_end ();
11270
11271   ffecom_char_args_ (&dest_tree, &dest_length, dest);
11272   ffecom_let_char_ (dest_tree, dest_length, ffebld_size_known (dest),
11273                     source);
11274 }
11275
11276 #endif
11277 /* ffecom_expr -- Transform expr into gcc tree
11278
11279    tree t;
11280    ffebld expr;  // FFE expression.
11281    tree = ffecom_expr(expr);
11282
11283    Recursive descent on expr while making corresponding tree nodes and
11284    attaching type info and such.  */
11285
11286 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11287 tree
11288 ffecom_expr (ffebld expr)
11289 {
11290   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, FALSE, FALSE);
11291 }
11292
11293 #endif
11294 /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT.  */
11295
11296 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11297 tree
11298 ffecom_expr_assign (ffebld expr)
11299 {
11300   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
11301 }
11302
11303 #endif
11304 /* Like ffecom_expr_rw, but return tree usable for ASSIGN.  */
11305
11306 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11307 tree
11308 ffecom_expr_assign_w (ffebld expr)
11309 {
11310   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
11311 }
11312
11313 #endif
11314 /* Transform expr for use as into read/write tree and stabilize the
11315    reference.  Not for use on CHARACTER expressions.
11316
11317    Recursive descent on expr while making corresponding tree nodes and
11318    attaching type info and such.  */
11319
11320 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11321 tree
11322 ffecom_expr_rw (tree type, ffebld expr)
11323 {
11324   assert (expr != NULL);
11325   /* Different target types not yet supported.  */
11326   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
11327
11328   return stabilize_reference (ffecom_expr (expr));
11329 }
11330
11331 #endif
11332 /* Transform expr for use as into write tree and stabilize the
11333    reference.  Not for use on CHARACTER expressions.
11334
11335    Recursive descent on expr while making corresponding tree nodes and
11336    attaching type info and such.  */
11337
11338 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11339 tree
11340 ffecom_expr_w (tree type, ffebld expr)
11341 {
11342   assert (expr != NULL);
11343   /* Different target types not yet supported.  */
11344   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
11345
11346   return stabilize_reference (ffecom_expr (expr));
11347 }
11348
11349 #endif
11350 /* Do global stuff.  */
11351
11352 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11353 void
11354 ffecom_finish_compile ()
11355 {
11356   assert (ffecom_outer_function_decl_ == NULL_TREE);
11357   assert (current_function_decl == NULL_TREE);
11358
11359   ffeglobal_drive (ffecom_finish_global_);
11360 }
11361
11362 #endif
11363 /* Public entry point for front end to access finish_decl.  */
11364
11365 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11366 void
11367 ffecom_finish_decl (tree decl, tree init, bool is_top_level)
11368 {
11369   assert (!is_top_level);
11370   finish_decl (decl, init, FALSE);
11371 }
11372
11373 #endif
11374 /* Finish a program unit.  */
11375
11376 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11377 void
11378 ffecom_finish_progunit ()
11379 {
11380   ffecom_end_compstmt ();
11381
11382   ffecom_previous_function_decl_ = current_function_decl;
11383   ffecom_which_entrypoint_decl_ = NULL_TREE;
11384
11385   finish_function (0);
11386 }
11387
11388 #endif
11389
11390 /* Wrapper for get_identifier.  pattern is sprintf-like.  */
11391
11392 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11393 tree
11394 ffecom_get_invented_identifier (const char *pattern, ...)
11395 {
11396   tree decl;
11397   char *nam;
11398   va_list ap;
11399
11400   va_start (ap, pattern);
11401   if (vasprintf (&nam, pattern, ap) == 0)
11402     abort ();
11403   va_end (ap);
11404   decl = get_identifier (nam);
11405   free (nam);
11406   IDENTIFIER_INVENTED (decl) = 1;
11407   return decl;
11408 }
11409
11410 ffeinfoBasictype
11411 ffecom_gfrt_basictype (ffecomGfrt gfrt)
11412 {
11413   assert (gfrt < FFECOM_gfrt);
11414
11415   switch (ffecom_gfrt_type_[gfrt])
11416     {
11417     case FFECOM_rttypeVOID_:
11418     case FFECOM_rttypeVOIDSTAR_:
11419       return FFEINFO_basictypeNONE;
11420
11421     case FFECOM_rttypeFTNINT_:
11422       return FFEINFO_basictypeINTEGER;
11423
11424     case FFECOM_rttypeINTEGER_:
11425       return FFEINFO_basictypeINTEGER;
11426
11427     case FFECOM_rttypeLONGINT_:
11428       return FFEINFO_basictypeINTEGER;
11429
11430     case FFECOM_rttypeLOGICAL_:
11431       return FFEINFO_basictypeLOGICAL;
11432
11433     case FFECOM_rttypeREAL_F2C_:
11434     case FFECOM_rttypeREAL_GNU_:
11435       return FFEINFO_basictypeREAL;
11436
11437     case FFECOM_rttypeCOMPLEX_F2C_:
11438     case FFECOM_rttypeCOMPLEX_GNU_:
11439       return FFEINFO_basictypeCOMPLEX;
11440
11441     case FFECOM_rttypeDOUBLE_:
11442     case FFECOM_rttypeDOUBLEREAL_:
11443       return FFEINFO_basictypeREAL;
11444
11445     case FFECOM_rttypeDBLCMPLX_F2C_:
11446     case FFECOM_rttypeDBLCMPLX_GNU_:
11447       return FFEINFO_basictypeCOMPLEX;
11448
11449     case FFECOM_rttypeCHARACTER_:
11450       return FFEINFO_basictypeCHARACTER;
11451
11452     default:
11453       return FFEINFO_basictypeANY;
11454     }
11455 }
11456
11457 ffeinfoKindtype
11458 ffecom_gfrt_kindtype (ffecomGfrt gfrt)
11459 {
11460   assert (gfrt < FFECOM_gfrt);
11461
11462   switch (ffecom_gfrt_type_[gfrt])
11463     {
11464     case FFECOM_rttypeVOID_:
11465     case FFECOM_rttypeVOIDSTAR_:
11466       return FFEINFO_kindtypeNONE;
11467
11468     case FFECOM_rttypeFTNINT_:
11469       return FFEINFO_kindtypeINTEGER1;
11470
11471     case FFECOM_rttypeINTEGER_:
11472       return FFEINFO_kindtypeINTEGER1;
11473
11474     case FFECOM_rttypeLONGINT_:
11475       return FFEINFO_kindtypeINTEGER4;
11476
11477     case FFECOM_rttypeLOGICAL_:
11478       return FFEINFO_kindtypeLOGICAL1;
11479
11480     case FFECOM_rttypeREAL_F2C_:
11481     case FFECOM_rttypeREAL_GNU_:
11482       return FFEINFO_kindtypeREAL1;
11483
11484     case FFECOM_rttypeCOMPLEX_F2C_:
11485     case FFECOM_rttypeCOMPLEX_GNU_:
11486       return FFEINFO_kindtypeREAL1;
11487
11488     case FFECOM_rttypeDOUBLE_:
11489     case FFECOM_rttypeDOUBLEREAL_:
11490       return FFEINFO_kindtypeREAL2;
11491
11492     case FFECOM_rttypeDBLCMPLX_F2C_:
11493     case FFECOM_rttypeDBLCMPLX_GNU_:
11494       return FFEINFO_kindtypeREAL2;
11495
11496     case FFECOM_rttypeCHARACTER_:
11497       return FFEINFO_kindtypeCHARACTER1;
11498
11499     default:
11500       return FFEINFO_kindtypeANY;
11501     }
11502 }
11503
11504 void
11505 ffecom_init_0 ()
11506 {
11507   tree endlink;
11508   int i;
11509   int j;
11510   tree t;
11511   tree field;
11512   ffetype type;
11513   ffetype base_type;
11514   tree double_ftype_double;
11515   tree float_ftype_float;
11516   tree ldouble_ftype_ldouble;
11517   tree ffecom_tree_ptr_to_fun_type_void;
11518
11519   /* This block of code comes from the now-obsolete cktyps.c.  It checks
11520      whether the compiler environment is buggy in known ways, some of which
11521      would, if not explicitly checked here, result in subtle bugs in g77.  */
11522
11523   if (ffe_is_do_internal_checks ())
11524     {
11525       static char names[][12]
11526         =
11527       {"bar", "bletch", "foo", "foobar"};
11528       char *name;
11529       unsigned long ul;
11530       double fl;
11531
11532       name = bsearch ("foo", &names[0], ARRAY_SIZE (names), sizeof (names[0]),
11533                       (int (*)(const void *, const void *)) strcmp);
11534       if (name != (char *) &names[2])
11535         {
11536           assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
11537                   == NULL);
11538           abort ();
11539         }
11540
11541       ul = strtoul ("123456789", NULL, 10);
11542       if (ul != 123456789L)
11543         {
11544           assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\
11545  in proj.h" == NULL);
11546           abort ();
11547         }
11548
11549       fl = atof ("56.789");
11550       if ((fl < 56.788) || (fl > 56.79))
11551         {
11552           assert ("atof not type double, fix your #include <stdio.h>"
11553                   == NULL);
11554           abort ();
11555         }
11556     }
11557
11558 #if FFECOM_GCC_INCLUDE
11559   ffecom_initialize_char_syntax_ ();
11560 #endif
11561
11562   ffecom_outer_function_decl_ = NULL_TREE;
11563   current_function_decl = NULL_TREE;
11564   named_labels = NULL_TREE;
11565   current_binding_level = NULL_BINDING_LEVEL;
11566   free_binding_level = NULL_BINDING_LEVEL;
11567   /* Make the binding_level structure for global names.  */
11568   pushlevel (0);
11569   global_binding_level = current_binding_level;
11570   current_binding_level->prep_state = 2;
11571
11572   build_common_tree_nodes (1);
11573
11574   /* Define `int' and `char' first so that dbx will output them first.  */
11575   pushdecl (build_decl (TYPE_DECL, get_identifier ("int"),
11576                         integer_type_node));
11577   pushdecl (build_decl (TYPE_DECL, get_identifier ("char"),
11578                         char_type_node));
11579   pushdecl (build_decl (TYPE_DECL, get_identifier ("long int"),
11580                         long_integer_type_node));
11581   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"),
11582                         unsigned_type_node));
11583   pushdecl (build_decl (TYPE_DECL, get_identifier ("long unsigned int"),
11584                         long_unsigned_type_node));
11585   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long int"),
11586                         long_long_integer_type_node));
11587   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long unsigned int"),
11588                         long_long_unsigned_type_node));
11589   pushdecl (build_decl (TYPE_DECL, get_identifier ("short int"),
11590                         short_integer_type_node));
11591   pushdecl (build_decl (TYPE_DECL, get_identifier ("short unsigned int"),
11592                         short_unsigned_type_node));
11593
11594   /* Set the sizetype before we make other types.  This *should* be the
11595      first type we create.  */
11596
11597   set_sizetype
11598     (TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE))));
11599   ffecom_typesize_pointer_
11600     = TREE_INT_CST_LOW (TYPE_SIZE (sizetype)) / BITS_PER_UNIT;
11601
11602   build_common_tree_nodes_2 (0);
11603
11604   /* Define both `signed char' and `unsigned char'.  */
11605   pushdecl (build_decl (TYPE_DECL, get_identifier ("signed char"),
11606                         signed_char_type_node));
11607
11608   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"),
11609                         unsigned_char_type_node));
11610
11611   pushdecl (build_decl (TYPE_DECL, get_identifier ("float"),
11612                         float_type_node));
11613   pushdecl (build_decl (TYPE_DECL, get_identifier ("double"),
11614                         double_type_node));
11615   pushdecl (build_decl (TYPE_DECL, get_identifier ("long double"),
11616                         long_double_type_node));
11617
11618   /* For now, override what build_common_tree_nodes has done.  */
11619   complex_integer_type_node = ffecom_make_complex_type_ (integer_type_node);
11620   complex_float_type_node = ffecom_make_complex_type_ (float_type_node);
11621   complex_double_type_node = ffecom_make_complex_type_ (double_type_node);
11622   complex_long_double_type_node
11623     = ffecom_make_complex_type_ (long_double_type_node);
11624
11625   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex int"),
11626                         complex_integer_type_node));
11627   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex float"),
11628                         complex_float_type_node));
11629   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex double"),
11630                         complex_double_type_node));
11631   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex long double"),
11632                         complex_long_double_type_node));
11633
11634   pushdecl (build_decl (TYPE_DECL, get_identifier ("void"),
11635                         void_type_node));
11636   /* We are not going to have real types in C with less than byte alignment,
11637      so we might as well not have any types that claim to have it.  */
11638   TYPE_ALIGN (void_type_node) = BITS_PER_UNIT;
11639
11640   string_type_node = build_pointer_type (char_type_node);
11641
11642   ffecom_tree_fun_type_void
11643     = build_function_type (void_type_node, NULL_TREE);
11644
11645   ffecom_tree_ptr_to_fun_type_void
11646     = build_pointer_type (ffecom_tree_fun_type_void);
11647
11648   endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
11649
11650   float_ftype_float
11651     = build_function_type (float_type_node,
11652                            tree_cons (NULL_TREE, float_type_node, endlink));
11653
11654   double_ftype_double
11655     = build_function_type (double_type_node,
11656                            tree_cons (NULL_TREE, double_type_node, endlink));
11657
11658   ldouble_ftype_ldouble
11659     = build_function_type (long_double_type_node,
11660                            tree_cons (NULL_TREE, long_double_type_node,
11661                                       endlink));
11662
11663   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11664     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11665       {
11666         ffecom_tree_type[i][j] = NULL_TREE;
11667         ffecom_tree_fun_type[i][j] = NULL_TREE;
11668         ffecom_tree_ptr_to_fun_type[i][j] = NULL_TREE;
11669         ffecom_f2c_typecode_[i][j] = -1;
11670       }
11671
11672   /* Set up standard g77 types.  Note that INTEGER and LOGICAL are set
11673      to size FLOAT_TYPE_SIZE because they have to be the same size as
11674      REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
11675      Compiler options and other such stuff that change the ways these
11676      types are set should not affect this particular setup.  */
11677
11678   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1]
11679     = t = make_signed_type (FLOAT_TYPE_SIZE);
11680   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer"),
11681                         t));
11682   type = ffetype_new ();
11683   base_type = type;
11684   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER1,
11685                     type);
11686   ffetype_set_ams (type,
11687                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11688                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11689   ffetype_set_star (base_type,
11690                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11691                     type);
11692   ffetype_set_kind (base_type, 1, type);
11693   ffecom_typesize_integer1_ = ffetype_size (type);
11694   assert (ffetype_size (type) == sizeof (ffetargetInteger1));
11695
11696   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER1]
11697     = t = make_unsigned_type (FLOAT_TYPE_SIZE); /* HOLLERITH means unsigned. */
11698   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned"),
11699                         t));
11700
11701   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER2]
11702     = t = make_signed_type (CHAR_TYPE_SIZE);
11703   pushdecl (build_decl (TYPE_DECL, get_identifier ("byte"),
11704                         t));
11705   type = ffetype_new ();
11706   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER2,
11707                     type);
11708   ffetype_set_ams (type,
11709                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11710                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11711   ffetype_set_star (base_type,
11712                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11713                     type);
11714   ffetype_set_kind (base_type, 3, type);
11715   assert (ffetype_size (type) == sizeof (ffetargetInteger2));
11716
11717   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER2]
11718     = t = make_unsigned_type (CHAR_TYPE_SIZE);
11719   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned byte"),
11720                         t));
11721
11722   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER3]
11723     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11724   pushdecl (build_decl (TYPE_DECL, get_identifier ("word"),
11725                         t));
11726   type = ffetype_new ();
11727   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER3,
11728                     type);
11729   ffetype_set_ams (type,
11730                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11731                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11732   ffetype_set_star (base_type,
11733                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11734                     type);
11735   ffetype_set_kind (base_type, 6, type);
11736   assert (ffetype_size (type) == sizeof (ffetargetInteger3));
11737
11738   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER3]
11739     = t = make_unsigned_type (CHAR_TYPE_SIZE * 2);
11740   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned word"),
11741                         t));
11742
11743   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER4]
11744     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11745   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer4"),
11746                         t));
11747   type = ffetype_new ();
11748   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER4,
11749                     type);
11750   ffetype_set_ams (type,
11751                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11752                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11753   ffetype_set_star (base_type,
11754                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11755                     type);
11756   ffetype_set_kind (base_type, 2, type);
11757   assert (ffetype_size (type) == sizeof (ffetargetInteger4));
11758
11759   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER4]
11760     = t = make_unsigned_type (FLOAT_TYPE_SIZE * 2);
11761   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned4"),
11762                         t));
11763
11764 #if 0
11765   if (ffe_is_do_internal_checks ()
11766       && LONG_TYPE_SIZE != FLOAT_TYPE_SIZE
11767       && LONG_TYPE_SIZE != CHAR_TYPE_SIZE
11768       && LONG_TYPE_SIZE != SHORT_TYPE_SIZE
11769       && LONG_TYPE_SIZE != LONG_LONG_TYPE_SIZE)
11770     {
11771       fprintf (stderr, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n",
11772                LONG_TYPE_SIZE);
11773     }
11774 #endif
11775
11776   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL1]
11777     = t = make_signed_type (FLOAT_TYPE_SIZE);
11778   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical"),
11779                         t));
11780   type = ffetype_new ();
11781   base_type = type;
11782   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL1,
11783                     type);
11784   ffetype_set_ams (type,
11785                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11786                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11787   ffetype_set_star (base_type,
11788                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11789                     type);
11790   ffetype_set_kind (base_type, 1, type);
11791   assert (ffetype_size (type) == sizeof (ffetargetLogical1));
11792
11793   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL2]
11794     = t = make_signed_type (CHAR_TYPE_SIZE);
11795   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical2"),
11796                         t));
11797   type = ffetype_new ();
11798   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL2,
11799                     type);
11800   ffetype_set_ams (type,
11801                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11802                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11803   ffetype_set_star (base_type,
11804                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11805                     type);
11806   ffetype_set_kind (base_type, 3, type);
11807   assert (ffetype_size (type) == sizeof (ffetargetLogical2));
11808
11809   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL3]
11810     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11811   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical3"),
11812                         t));
11813   type = ffetype_new ();
11814   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL3,
11815                     type);
11816   ffetype_set_ams (type,
11817                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11818                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11819   ffetype_set_star (base_type,
11820                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11821                     type);
11822   ffetype_set_kind (base_type, 6, type);
11823   assert (ffetype_size (type) == sizeof (ffetargetLogical3));
11824
11825   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL4]
11826     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11827   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical4"),
11828                         t));
11829   type = ffetype_new ();
11830   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL4,
11831                     type);
11832   ffetype_set_ams (type,
11833                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11834                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11835   ffetype_set_star (base_type,
11836                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11837                     type);
11838   ffetype_set_kind (base_type, 2, type);
11839   assert (ffetype_size (type) == sizeof (ffetargetLogical4));
11840
11841   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11842     = t = make_node (REAL_TYPE);
11843   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE;
11844   pushdecl (build_decl (TYPE_DECL, get_identifier ("real"),
11845                         t));
11846   layout_type (t);
11847   type = ffetype_new ();
11848   base_type = type;
11849   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL1,
11850                     type);
11851   ffetype_set_ams (type,
11852                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11853                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11854   ffetype_set_star (base_type,
11855                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11856                     type);
11857   ffetype_set_kind (base_type, 1, type);
11858   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11859     = FFETARGET_f2cTYREAL;
11860   assert (ffetype_size (type) == sizeof (ffetargetReal1));
11861
11862   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREALDOUBLE]
11863     = t = make_node (REAL_TYPE);
11864   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE * 2;     /* Always twice REAL. */
11865   pushdecl (build_decl (TYPE_DECL, get_identifier ("double precision"),
11866                         t));
11867   layout_type (t);
11868   type = ffetype_new ();
11869   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
11870                     type);
11871   ffetype_set_ams (type,
11872                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11873                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11874   ffetype_set_star (base_type,
11875                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11876                     type);
11877   ffetype_set_kind (base_type, 2, type);
11878   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]
11879     = FFETARGET_f2cTYDREAL;
11880   assert (ffetype_size (type) == sizeof (ffetargetReal2));
11881
11882   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11883     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]);
11884   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex"),
11885                         t));
11886   type = ffetype_new ();
11887   base_type = type;
11888   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL1,
11889                     type);
11890   ffetype_set_ams (type,
11891                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11892                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11893   ffetype_set_star (base_type,
11894                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11895                     type);
11896   ffetype_set_kind (base_type, 1, type);
11897   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11898     = FFETARGET_f2cTYCOMPLEX;
11899   assert (ffetype_size (type) == sizeof (ffetargetComplex1));
11900
11901   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREALDOUBLE]
11902     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]);
11903   pushdecl (build_decl (TYPE_DECL, get_identifier ("double complex"),
11904                         t));
11905   type = ffetype_new ();
11906   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREALDOUBLE,
11907                     type);
11908   ffetype_set_ams (type,
11909                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11910                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11911   ffetype_set_star (base_type,
11912                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11913                     type);
11914   ffetype_set_kind (base_type, 2,
11915                     type);
11916   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL2]
11917     = FFETARGET_f2cTYDCOMPLEX;
11918   assert (ffetype_size (type) == sizeof (ffetargetComplex2));
11919
11920   /* Make function and ptr-to-function types for non-CHARACTER types. */
11921
11922   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11923     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11924       {
11925         if ((t = ffecom_tree_type[i][j]) != NULL_TREE)
11926           {
11927             if (i == FFEINFO_basictypeINTEGER)
11928               {
11929                 /* Figure out the smallest INTEGER type that can hold
11930                    a pointer on this machine. */
11931                 if (GET_MODE_SIZE (TYPE_MODE (t))
11932                     >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
11933                   {
11934                     if ((ffecom_pointer_kind_ == FFEINFO_kindtypeNONE)
11935                         || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type[i][ffecom_pointer_kind_]))
11936                             > GET_MODE_SIZE (TYPE_MODE (t))))
11937                       ffecom_pointer_kind_ = j;
11938                   }
11939               }
11940             else if (i == FFEINFO_basictypeCOMPLEX)
11941               t = void_type_node;
11942             /* For f2c compatibility, REAL functions are really
11943                implemented as DOUBLE PRECISION.  */
11944             else if ((i == FFEINFO_basictypeREAL)
11945                      && (j == FFEINFO_kindtypeREAL1))
11946               t = ffecom_tree_type
11947                 [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2];
11948
11949             t = ffecom_tree_fun_type[i][j] = build_function_type (t,
11950                                                                   NULL_TREE);
11951             ffecom_tree_ptr_to_fun_type[i][j] = build_pointer_type (t);
11952           }
11953       }
11954
11955   /* Set up pointer types.  */
11956
11957   if (ffecom_pointer_kind_ == FFEINFO_basictypeNONE)
11958     fatal ("no INTEGER type can hold a pointer on this configuration");
11959   else if (0 && ffe_is_do_internal_checks ())
11960     fprintf (stderr, "Pointer type kt=%d\n", ffecom_pointer_kind_);
11961   ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER,
11962                                   FFEINFO_kindtypeINTEGERDEFAULT),
11963                     7,
11964                     ffeinfo_type (FFEINFO_basictypeINTEGER,
11965                                   ffecom_pointer_kind_));
11966
11967   if (ffe_is_ugly_assign ())
11968     ffecom_label_kind_ = ffecom_pointer_kind_;  /* Require ASSIGN etc to this. */
11969   else
11970     ffecom_label_kind_ = FFEINFO_kindtypeINTEGERDEFAULT;
11971   if (0 && ffe_is_do_internal_checks ())
11972     fprintf (stderr, "Label type kt=%d\n", ffecom_label_kind_);
11973
11974   ffecom_integer_type_node
11975     = ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1];
11976   ffecom_integer_zero_node = convert (ffecom_integer_type_node,
11977                                       integer_zero_node);
11978   ffecom_integer_one_node = convert (ffecom_integer_type_node,
11979                                      integer_one_node);
11980
11981   /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
11982      Turns out that by TYLONG, runtime/libI77/lio.h really means
11983      "whatever size an ftnint is".  For consistency and sanity,
11984      com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
11985      all are INTEGER, which we also make out of whatever back-end
11986      integer type is FLOAT_TYPE_SIZE bits wide.  This change, from
11987      LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
11988      accommodate machines like the Alpha.  Note that this suggests
11989      f2c and libf2c are missing a distinction perhaps needed on
11990      some machines between "int" and "long int".  -- burley 0.5.5 950215 */
11991
11992   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, FLOAT_TYPE_SIZE,
11993                             FFETARGET_f2cTYLONG);
11994   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, SHORT_TYPE_SIZE,
11995                             FFETARGET_f2cTYSHORT);
11996   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, CHAR_TYPE_SIZE,
11997                             FFETARGET_f2cTYINT1);
11998   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, LONG_LONG_TYPE_SIZE,
11999                             FFETARGET_f2cTYQUAD);
12000   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, FLOAT_TYPE_SIZE,
12001                             FFETARGET_f2cTYLOGICAL);
12002   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, SHORT_TYPE_SIZE,
12003                             FFETARGET_f2cTYLOGICAL2);
12004   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, CHAR_TYPE_SIZE,
12005                             FFETARGET_f2cTYLOGICAL1);
12006   /* ~~~Not really such a type in libf2c, e.g. I/O support?  */
12007   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, LONG_LONG_TYPE_SIZE,
12008                             FFETARGET_f2cTYQUAD);
12009
12010   /* CHARACTER stuff is all special-cased, so it is not handled in the above
12011      loop.  CHARACTER items are built as arrays of unsigned char.  */
12012
12013   ffecom_tree_type[FFEINFO_basictypeCHARACTER]
12014     [FFEINFO_kindtypeCHARACTER1] = t = char_type_node;
12015   type = ffetype_new ();
12016   base_type = type;
12017   ffeinfo_set_type (FFEINFO_basictypeCHARACTER,
12018                     FFEINFO_kindtypeCHARACTER1,
12019                     type);
12020   ffetype_set_ams (type,
12021                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
12022                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
12023   ffetype_set_kind (base_type, 1, type);
12024   assert (ffetype_size (type)
12025           == sizeof (((ffetargetCharacter1) { 0, NULL }).text[0]));
12026
12027   ffecom_tree_fun_type[FFEINFO_basictypeCHARACTER]
12028     [FFEINFO_kindtypeCHARACTER1] = ffecom_tree_fun_type_void;
12029   ffecom_tree_ptr_to_fun_type[FFEINFO_basictypeCHARACTER]
12030     [FFEINFO_kindtypeCHARACTER1]
12031     = ffecom_tree_ptr_to_fun_type_void;
12032   ffecom_f2c_typecode_[FFEINFO_basictypeCHARACTER][FFEINFO_kindtypeCHARACTER1]
12033     = FFETARGET_f2cTYCHAR;
12034
12035   ffecom_f2c_typecode_[FFEINFO_basictypeANY][FFEINFO_kindtypeANY]
12036     = 0;
12037
12038   /* Make multi-return-value type and fields. */
12039
12040   ffecom_multi_type_node_ = make_node (UNION_TYPE);
12041
12042   field = NULL_TREE;
12043
12044   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
12045     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
12046       {
12047         char name[30];
12048
12049         if (ffecom_tree_type[i][j] == NULL_TREE)
12050           continue;             /* Not supported. */
12051         sprintf (&name[0], "bt_%s_kt_%s",
12052                  ffeinfo_basictype_string ((ffeinfoBasictype) i),
12053                  ffeinfo_kindtype_string ((ffeinfoKindtype) j));
12054         ffecom_multi_fields_[i][j] = build_decl (FIELD_DECL,
12055                                                  get_identifier (name),
12056                                                  ffecom_tree_type[i][j]);
12057         DECL_CONTEXT (ffecom_multi_fields_[i][j])
12058           = ffecom_multi_type_node_;
12059         DECL_FRAME_SIZE (ffecom_multi_fields_[i][j]) = 0;
12060         TREE_CHAIN (ffecom_multi_fields_[i][j]) = field;
12061         field = ffecom_multi_fields_[i][j];
12062       }
12063
12064   TYPE_FIELDS (ffecom_multi_type_node_) = field;
12065   layout_type (ffecom_multi_type_node_);
12066
12067   /* Subroutines usually return integer because they might have alternate
12068      returns. */
12069
12070   ffecom_tree_subr_type
12071     = build_function_type (integer_type_node, NULL_TREE);
12072   ffecom_tree_ptr_to_subr_type
12073     = build_pointer_type (ffecom_tree_subr_type);
12074   ffecom_tree_blockdata_type
12075     = build_function_type (void_type_node, NULL_TREE);
12076
12077   builtin_function ("__builtin_sqrtf", float_ftype_float,
12078                     BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrtf");
12079   builtin_function ("__builtin_fsqrt", double_ftype_double,
12080                     BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrt");
12081   builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble,
12082                     BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrtl");
12083   builtin_function ("__builtin_sinf", float_ftype_float,
12084                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sinf");
12085   builtin_function ("__builtin_sin", double_ftype_double,
12086                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sin");
12087   builtin_function ("__builtin_sinl", ldouble_ftype_ldouble,
12088                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sinl");
12089   builtin_function ("__builtin_cosf", float_ftype_float,
12090                     BUILT_IN_COS, BUILT_IN_NORMAL, "cosf");
12091   builtin_function ("__builtin_cos", double_ftype_double,
12092                     BUILT_IN_COS, BUILT_IN_NORMAL, "cos");
12093   builtin_function ("__builtin_cosl", ldouble_ftype_ldouble,
12094                     BUILT_IN_COS, BUILT_IN_NORMAL, "cosl");
12095
12096 #if BUILT_FOR_270
12097   pedantic_lvalues = FALSE;
12098 #endif
12099
12100   ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node,
12101                          FFECOM_f2cINTEGER,
12102                          "integer");
12103   ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node,
12104                          FFECOM_f2cADDRESS,
12105                          "address");
12106   ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node,
12107                          FFECOM_f2cREAL,
12108                          "real");
12109   ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node,
12110                          FFECOM_f2cDOUBLEREAL,
12111                          "doublereal");
12112   ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node,
12113                          FFECOM_f2cCOMPLEX,
12114                          "complex");
12115   ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node,
12116                          FFECOM_f2cDOUBLECOMPLEX,
12117                          "doublecomplex");
12118   ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node,
12119                          FFECOM_f2cLONGINT,
12120                          "longint");
12121   ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node,
12122                          FFECOM_f2cLOGICAL,
12123                          "logical");
12124   ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node,
12125                          FFECOM_f2cFLAG,
12126                          "flag");
12127   ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node,
12128                          FFECOM_f2cFTNLEN,
12129                          "ftnlen");
12130   ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node,
12131                          FFECOM_f2cFTNINT,
12132                          "ftnint");
12133
12134   ffecom_f2c_ftnlen_zero_node
12135     = convert (ffecom_f2c_ftnlen_type_node, integer_zero_node);
12136
12137   ffecom_f2c_ftnlen_one_node
12138     = convert (ffecom_f2c_ftnlen_type_node, integer_one_node);
12139
12140   ffecom_f2c_ftnlen_two_node = build_int_2 (2, 0);
12141   TREE_TYPE (ffecom_f2c_ftnlen_two_node) = ffecom_integer_type_node;
12142
12143   ffecom_f2c_ptr_to_ftnlen_type_node
12144     = build_pointer_type (ffecom_f2c_ftnlen_type_node);
12145
12146   ffecom_f2c_ptr_to_ftnint_type_node
12147     = build_pointer_type (ffecom_f2c_ftnint_type_node);
12148
12149   ffecom_f2c_ptr_to_integer_type_node
12150     = build_pointer_type (ffecom_f2c_integer_type_node);
12151
12152   ffecom_f2c_ptr_to_real_type_node
12153     = build_pointer_type (ffecom_f2c_real_type_node);
12154
12155   ffecom_float_zero_ = build_real (float_type_node, dconst0);
12156   ffecom_double_zero_ = build_real (double_type_node, dconst0);
12157   {
12158     REAL_VALUE_TYPE point_5;
12159
12160 #ifdef REAL_ARITHMETIC
12161     REAL_ARITHMETIC (point_5, RDIV_EXPR, dconst1, dconst2);
12162 #else
12163     point_5 = .5;
12164 #endif
12165     ffecom_float_half_ = build_real (float_type_node, point_5);
12166     ffecom_double_half_ = build_real (double_type_node, point_5);
12167   }
12168
12169   /* Do "extern int xargc;".  */
12170
12171   ffecom_tree_xargc_ = build_decl (VAR_DECL,
12172                                    get_identifier ("f__xargc"),
12173                                    integer_type_node);
12174   DECL_EXTERNAL (ffecom_tree_xargc_) = 1;
12175   TREE_STATIC (ffecom_tree_xargc_) = 1;
12176   TREE_PUBLIC (ffecom_tree_xargc_) = 1;
12177   ffecom_tree_xargc_ = start_decl (ffecom_tree_xargc_, FALSE);
12178   finish_decl (ffecom_tree_xargc_, NULL_TREE, FALSE);
12179
12180 #if 0   /* This is being fixed, and seems to be working now. */
12181   if ((FLOAT_TYPE_SIZE != 32)
12182       || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))) != 32))
12183     {
12184       warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,",
12185                (int) FLOAT_TYPE_SIZE);
12186       warning ("and pointers are %d bits wide, but g77 doesn't yet work",
12187           (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))));
12188       warning ("properly unless they all are 32 bits wide.");
12189       warning ("Please keep this in mind before you report bugs.  g77 should");
12190       warning ("support non-32-bit machines better as of version 0.6.");
12191     }
12192 #endif
12193
12194 #if 0   /* Code in ste.c that would crash has been commented out. */
12195   if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
12196       < TYPE_PRECISION (string_type_node))
12197     /* I/O will probably crash.  */
12198     warning ("configuration: char * holds %d bits, but ftnlen only %d",
12199              TYPE_PRECISION (string_type_node),
12200              TYPE_PRECISION (ffecom_f2c_ftnlen_type_node));
12201 #endif
12202
12203 #if 0   /* ASSIGN-related stuff has been changed to accommodate this. */
12204   if (TYPE_PRECISION (ffecom_integer_type_node)
12205       < TYPE_PRECISION (string_type_node))
12206     /* ASSIGN 10 TO I will crash.  */
12207     warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
12208  ASSIGN statement might fail",
12209              TYPE_PRECISION (string_type_node),
12210              TYPE_PRECISION (ffecom_integer_type_node));
12211 #endif
12212 }
12213
12214 #endif
12215 /* ffecom_init_2 -- Initialize
12216
12217    ffecom_init_2();  */
12218
12219 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12220 void
12221 ffecom_init_2 ()
12222 {
12223   assert (ffecom_outer_function_decl_ == NULL_TREE);
12224   assert (current_function_decl == NULL_TREE);
12225   assert (ffecom_which_entrypoint_decl_ == NULL_TREE);
12226
12227   ffecom_master_arglist_ = NULL;
12228   ++ffecom_num_fns_;
12229   ffecom_primary_entry_ = NULL;
12230   ffecom_is_altreturning_ = FALSE;
12231   ffecom_func_result_ = NULL_TREE;
12232   ffecom_multi_retval_ = NULL_TREE;
12233 }
12234
12235 #endif
12236 /* ffecom_list_expr -- Transform list of exprs into gcc tree
12237
12238    tree t;
12239    ffebld expr;  // FFE opITEM list.
12240    tree = ffecom_list_expr(expr);
12241
12242    List of actual args is transformed into corresponding gcc backend list.  */
12243
12244 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12245 tree
12246 ffecom_list_expr (ffebld expr)
12247 {
12248   tree list;
12249   tree *plist = &list;
12250   tree trail = NULL_TREE;       /* Append char length args here. */
12251   tree *ptrail = &trail;
12252   tree length;
12253
12254   while (expr != NULL)
12255     {
12256       tree texpr = ffecom_arg_expr (ffebld_head (expr), &length);
12257
12258       if (texpr == error_mark_node)
12259         return error_mark_node;
12260
12261       *plist = build_tree_list (NULL_TREE, texpr);
12262       plist = &TREE_CHAIN (*plist);
12263       expr = ffebld_trail (expr);
12264       if (length != NULL_TREE)
12265         {
12266           *ptrail = build_tree_list (NULL_TREE, length);
12267           ptrail = &TREE_CHAIN (*ptrail);
12268         }
12269     }
12270
12271   *plist = trail;
12272
12273   return list;
12274 }
12275
12276 #endif
12277 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
12278
12279    tree t;
12280    ffebld expr;  // FFE opITEM list.
12281    tree = ffecom_list_ptr_to_expr(expr);
12282
12283    List of actual args is transformed into corresponding gcc backend list for
12284    use in calling an external procedure (vs. a statement function).  */
12285
12286 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12287 tree
12288 ffecom_list_ptr_to_expr (ffebld expr)
12289 {
12290   tree list;
12291   tree *plist = &list;
12292   tree trail = NULL_TREE;       /* Append char length args here. */
12293   tree *ptrail = &trail;
12294   tree length;
12295
12296   while (expr != NULL)
12297     {
12298       tree texpr = ffecom_arg_ptr_to_expr (ffebld_head (expr), &length);
12299
12300       if (texpr == error_mark_node)
12301         return error_mark_node;
12302
12303       *plist = build_tree_list (NULL_TREE, texpr);
12304       plist = &TREE_CHAIN (*plist);
12305       expr = ffebld_trail (expr);
12306       if (length != NULL_TREE)
12307         {
12308           *ptrail = build_tree_list (NULL_TREE, length);
12309           ptrail = &TREE_CHAIN (*ptrail);
12310         }
12311     }
12312
12313   *plist = trail;
12314
12315   return list;
12316 }
12317
12318 #endif
12319 /* Obtain gcc's LABEL_DECL tree for label.  */
12320
12321 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12322 tree
12323 ffecom_lookup_label (ffelab label)
12324 {
12325   tree glabel;
12326
12327   if (ffelab_hook (label) == NULL_TREE)
12328     {
12329       char labelname[16];
12330
12331       switch (ffelab_type (label))
12332         {
12333         case FFELAB_typeLOOPEND:
12334         case FFELAB_typeNOTLOOP:
12335         case FFELAB_typeENDIF:
12336           sprintf (labelname, "%" ffelabValue_f "u", ffelab_value (label));
12337           glabel = build_decl (LABEL_DECL, get_identifier (labelname),
12338                                void_type_node);
12339           DECL_CONTEXT (glabel) = current_function_decl;
12340           DECL_MODE (glabel) = VOIDmode;
12341           break;
12342
12343         case FFELAB_typeFORMAT:
12344           glabel = build_decl (VAR_DECL,
12345                                ffecom_get_invented_identifier
12346                                ("__g77_format_%d", (int) ffelab_value (label)),
12347                                build_type_variant (build_array_type
12348                                                    (char_type_node,
12349                                                     NULL_TREE),
12350                                                    1, 0));
12351           TREE_CONSTANT (glabel) = 1;
12352           TREE_STATIC (glabel) = 1;
12353           DECL_CONTEXT (glabel) = 0;
12354           DECL_INITIAL (glabel) = NULL;
12355           make_decl_rtl (glabel, NULL, 0);
12356           expand_decl (glabel);
12357
12358           ffecom_save_tree_forever (glabel);
12359
12360           break;
12361
12362         case FFELAB_typeANY:
12363           glabel = error_mark_node;
12364           break;
12365
12366         default:
12367           assert ("bad label type" == NULL);
12368           glabel = NULL;
12369           break;
12370         }
12371       ffelab_set_hook (label, glabel);
12372     }
12373   else
12374     {
12375       glabel = ffelab_hook (label);
12376     }
12377
12378   return glabel;
12379 }
12380
12381 #endif
12382 /* Stabilizes the arguments.  Don't use this if the lhs and rhs come from
12383    a single source specification (as in the fourth argument of MVBITS).
12384    If the type is NULL_TREE, the type of lhs is used to make the type of
12385    the MODIFY_EXPR.  */
12386
12387 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12388 tree
12389 ffecom_modify (tree newtype, tree lhs,
12390                tree rhs)
12391 {
12392   if (lhs == error_mark_node || rhs == error_mark_node)
12393     return error_mark_node;
12394
12395   if (newtype == NULL_TREE)
12396     newtype = TREE_TYPE (lhs);
12397
12398   if (TREE_SIDE_EFFECTS (lhs))
12399     lhs = stabilize_reference (lhs);
12400
12401   return ffecom_2s (MODIFY_EXPR, newtype, lhs, rhs);
12402 }
12403
12404 #endif
12405
12406 /* Register source file name.  */
12407
12408 void
12409 ffecom_file (const char *name)
12410 {
12411 #if FFECOM_GCC_INCLUDE
12412   ffecom_file_ (name);
12413 #endif
12414 }
12415
12416 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
12417
12418    ffestorag st;
12419    ffecom_notify_init_storage(st);
12420
12421    Gets called when all possible units in an aggregate storage area (a LOCAL
12422    with equivalences or a COMMON) have been initialized.  The initialization
12423    info either is in ffestorag_init or, if that is NULL,
12424    ffestorag_accretion:
12425
12426    ffestorag_init may contain an opCONTER or opARRTER.  opCONTER may occur
12427    even for an array if the array is one element in length!
12428
12429    ffestorag_accretion will contain an opACCTER.  It is much like an
12430    opARRTER except it has an ffebit object in it instead of just a size.
12431    The back end can use the info in the ffebit object, if it wants, to
12432    reduce the amount of actual initialization, but in any case it should
12433    kill the ffebit object when done.  Also, set accretion to NULL but
12434    init to a non-NULL value.
12435
12436    After performing initialization, DO NOT set init to NULL, because that'll
12437    tell the front end it is ok for more initialization to happen.  Instead,
12438    set init to an opANY expression or some such thing that you can use to
12439    tell that you've already initialized the object.
12440
12441    27-Oct-91  JCB  1.1
12442       Support two-pass FFE.  */
12443
12444 void
12445 ffecom_notify_init_storage (ffestorag st)
12446 {
12447   ffebld init;                  /* The initialization expression. */
12448 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12449   ffetargetOffset size;         /* The size of the entity. */
12450   ffetargetAlign pad;           /* Its initial padding. */
12451 #endif
12452
12453   if (ffestorag_init (st) == NULL)
12454     {
12455       init = ffestorag_accretion (st);
12456       assert (init != NULL);
12457       ffestorag_set_accretion (st, NULL);
12458       ffestorag_set_accretes (st, 0);
12459
12460 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12461       /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12462       size = ffebld_accter_size (init);
12463       pad = ffebld_accter_pad (init);
12464       ffebit_kill (ffebld_accter_bits (init));
12465       ffebld_set_op (init, FFEBLD_opARRTER);
12466       ffebld_set_arrter (init, ffebld_accter (init));
12467       ffebld_arrter_set_size (init, size);
12468       ffebld_arrter_set_pad (init, size);
12469 #endif
12470
12471 #if FFECOM_TWOPASS
12472       ffestorag_set_init (st, init);
12473 #endif
12474     }
12475 #if FFECOM_ONEPASS
12476   else
12477     init = ffestorag_init (st);
12478 #endif
12479
12480 #if FFECOM_ONEPASS              /* Process the inits, wipe 'em out. */
12481   ffestorag_set_init (st, ffebld_new_any ());
12482
12483   if (ffebld_op (init) == FFEBLD_opANY)
12484     return;                     /* Oh, we already did this! */
12485
12486 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12487   {
12488     ffesymbol s;
12489
12490     if (ffestorag_symbol (st) != NULL)
12491       s = ffestorag_symbol (st);
12492     else
12493       s = ffestorag_typesymbol (st);
12494
12495     fprintf (dmpout, "= initialize_storage \"%s\" ",
12496              (s != NULL) ? ffesymbol_text (s) : "(unnamed)");
12497     ffebld_dump (init);
12498     fputc ('\n', dmpout);
12499   }
12500 #endif
12501
12502 #endif /* if FFECOM_ONEPASS */
12503 }
12504
12505 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12506
12507    ffesymbol s;
12508    ffecom_notify_init_symbol(s);
12509
12510    Gets called when all possible units in a symbol (not placed in COMMON
12511    or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12512    have been initialized.  The initialization info either is in
12513    ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12514
12515    ffesymbol_init may contain an opCONTER or opARRTER.  opCONTER may occur
12516    even for an array if the array is one element in length!
12517
12518    ffesymbol_accretion will contain an opACCTER.  It is much like an
12519    opARRTER except it has an ffebit object in it instead of just a size.
12520    The back end can use the info in the ffebit object, if it wants, to
12521    reduce the amount of actual initialization, but in any case it should
12522    kill the ffebit object when done.  Also, set accretion to NULL but
12523    init to a non-NULL value.
12524
12525    After performing initialization, DO NOT set init to NULL, because that'll
12526    tell the front end it is ok for more initialization to happen.  Instead,
12527    set init to an opANY expression or some such thing that you can use to
12528    tell that you've already initialized the object.
12529
12530    27-Oct-91  JCB  1.1
12531       Support two-pass FFE.  */
12532
12533 void
12534 ffecom_notify_init_symbol (ffesymbol s)
12535 {
12536   ffebld init;                  /* The initialization expression. */
12537 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12538   ffetargetOffset size;         /* The size of the entity. */
12539   ffetargetAlign pad;           /* Its initial padding. */
12540 #endif
12541
12542   if (ffesymbol_storage (s) == NULL)
12543     return;                     /* Do nothing until COMMON/EQUIVALENCE
12544                                    possibilities checked. */
12545
12546   if ((ffesymbol_init (s) == NULL)
12547       && ((init = ffesymbol_accretion (s)) != NULL))
12548     {
12549       ffesymbol_set_accretion (s, NULL);
12550       ffesymbol_set_accretes (s, 0);
12551
12552 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12553       /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12554       size = ffebld_accter_size (init);
12555       pad = ffebld_accter_pad (init);
12556       ffebit_kill (ffebld_accter_bits (init));
12557       ffebld_set_op (init, FFEBLD_opARRTER);
12558       ffebld_set_arrter (init, ffebld_accter (init));
12559       ffebld_arrter_set_size (init, size);
12560       ffebld_arrter_set_pad (init, size);
12561 #endif
12562
12563 #if FFECOM_TWOPASS
12564       ffesymbol_set_init (s, init);
12565 #endif
12566     }
12567 #if FFECOM_ONEPASS
12568   else
12569     init = ffesymbol_init (s);
12570 #endif
12571
12572 #if FFECOM_ONEPASS
12573   ffesymbol_set_init (s, ffebld_new_any ());
12574
12575   if (ffebld_op (init) == FFEBLD_opANY)
12576     return;                     /* Oh, we already did this! */
12577
12578 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12579   fprintf (dmpout, "= initialize_symbol \"%s\" ", ffesymbol_text (s));
12580   ffebld_dump (init);
12581   fputc ('\n', dmpout);
12582 #endif
12583
12584 #endif /* if FFECOM_ONEPASS */
12585 }
12586
12587 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12588
12589    ffesymbol s;
12590    ffecom_notify_primary_entry(s);
12591
12592    Gets called when implicit or explicit PROGRAM statement seen or when
12593    FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12594    global symbol that serves as the entry point.  */
12595
12596 void
12597 ffecom_notify_primary_entry (ffesymbol s)
12598 {
12599   ffecom_primary_entry_ = s;
12600   ffecom_primary_entry_kind_ = ffesymbol_kind (s);
12601
12602   if ((ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
12603       || (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE))
12604     ffecom_primary_entry_is_proc_ = TRUE;
12605   else
12606     ffecom_primary_entry_is_proc_ = FALSE;
12607
12608   if (!ffe_is_silent ())
12609     {
12610       if (ffecom_primary_entry_kind_ == FFEINFO_kindPROGRAM)
12611         fprintf (stderr, "%s:\n", ffesymbol_text (s));
12612       else
12613         fprintf (stderr, "  %s:\n", ffesymbol_text (s));
12614     }
12615
12616 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12617   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
12618     {
12619       ffebld list;
12620       ffebld arg;
12621
12622       for (list = ffesymbol_dummyargs (s);
12623            list != NULL;
12624            list = ffebld_trail (list))
12625         {
12626           arg = ffebld_head (list);
12627           if (ffebld_op (arg) == FFEBLD_opSTAR)
12628             {
12629               ffecom_is_altreturning_ = TRUE;
12630               break;
12631             }
12632         }
12633     }
12634 #endif
12635 }
12636
12637 FILE *
12638 ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c)
12639 {
12640 #if FFECOM_GCC_INCLUDE
12641   return ffecom_open_include_ (name, l, c);
12642 #else
12643   return fopen (name, "r");
12644 #endif
12645 }
12646
12647 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
12648
12649    tree t;
12650    ffebld expr;  // FFE expression.
12651    tree = ffecom_ptr_to_expr(expr);
12652
12653    Like ffecom_expr, but sticks address-of in front of most things.  */
12654
12655 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12656 tree
12657 ffecom_ptr_to_expr (ffebld expr)
12658 {
12659   tree item;
12660   ffeinfoBasictype bt;
12661   ffeinfoKindtype kt;
12662   ffesymbol s;
12663
12664   assert (expr != NULL);
12665
12666   switch (ffebld_op (expr))
12667     {
12668     case FFEBLD_opSYMTER:
12669       s = ffebld_symter (expr);
12670       if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
12671         {
12672           ffecomGfrt ix;
12673
12674           ix = ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr));
12675           assert (ix != FFECOM_gfrt);
12676           if ((item = ffecom_gfrt_[ix]) == NULL_TREE)
12677             {
12678               ffecom_make_gfrt_ (ix);
12679               item = ffecom_gfrt_[ix];
12680             }
12681         }
12682       else
12683         {
12684           item = ffesymbol_hook (s).decl_tree;
12685           if (item == NULL_TREE)
12686             {
12687               s = ffecom_sym_transform_ (s);
12688               item = ffesymbol_hook (s).decl_tree;
12689             }
12690         }
12691       assert (item != NULL);
12692       if (item == error_mark_node)
12693         return item;
12694       if (!ffesymbol_hook (s).addr)
12695         item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12696                          item);
12697       return item;
12698
12699     case FFEBLD_opARRAYREF:
12700       return ffecom_arrayref_ (NULL_TREE, expr, 1);
12701
12702     case FFEBLD_opCONTER:
12703
12704       bt = ffeinfo_basictype (ffebld_info (expr));
12705       kt = ffeinfo_kindtype (ffebld_info (expr));
12706
12707       item = ffecom_constantunion (&ffebld_constant_union
12708                                    (ffebld_conter (expr)), bt, kt,
12709                                    ffecom_tree_type[bt][kt]);
12710       if (item == error_mark_node)
12711         return error_mark_node;
12712       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12713                        item);
12714       return item;
12715
12716     case FFEBLD_opANY:
12717       return error_mark_node;
12718
12719     default:
12720       bt = ffeinfo_basictype (ffebld_info (expr));
12721       kt = ffeinfo_kindtype (ffebld_info (expr));
12722
12723       item = ffecom_expr (expr);
12724       if (item == error_mark_node)
12725         return error_mark_node;
12726
12727       /* The back end currently optimizes a bit too zealously for us, in that
12728          we fail JCB001 if the following block of code is omitted.  It checks
12729          to see if the transformed expression is a symbol or array reference,
12730          and encloses it in a SAVE_EXPR if that is the case.  */
12731
12732       STRIP_NOPS (item);
12733       if ((TREE_CODE (item) == VAR_DECL)
12734           || (TREE_CODE (item) == PARM_DECL)
12735           || (TREE_CODE (item) == RESULT_DECL)
12736           || (TREE_CODE (item) == INDIRECT_REF)
12737           || (TREE_CODE (item) == ARRAY_REF)
12738           || (TREE_CODE (item) == COMPONENT_REF)
12739 #ifdef OFFSET_REF
12740           || (TREE_CODE (item) == OFFSET_REF)
12741 #endif
12742           || (TREE_CODE (item) == BUFFER_REF)
12743           || (TREE_CODE (item) == REALPART_EXPR)
12744           || (TREE_CODE (item) == IMAGPART_EXPR))
12745         {
12746           item = ffecom_save_tree (item);
12747         }
12748
12749       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12750                        item);
12751       return item;
12752     }
12753
12754   assert ("fall-through error" == NULL);
12755   return error_mark_node;
12756 }
12757
12758 #endif
12759 /* Obtain a temp var with given data type.
12760
12761    size is FFETARGET_charactersizeNONE for a non-CHARACTER type
12762    or >= 0 for a CHARACTER type.
12763
12764    elements is -1 for a scalar or > 0 for an array of type.  */
12765
12766 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12767 tree
12768 ffecom_make_tempvar (const char *commentary, tree type,
12769                      ffetargetCharacterSize size, int elements)
12770 {
12771   int yes;
12772   tree t;
12773   static int mynumber;
12774
12775   assert (current_binding_level->prep_state < 2);
12776
12777   if (type == error_mark_node)
12778     return error_mark_node;
12779
12780   yes = suspend_momentary ();
12781
12782   if (size != FFETARGET_charactersizeNONE)
12783     type = build_array_type (type,
12784                              build_range_type (ffecom_f2c_ftnlen_type_node,
12785                                                ffecom_f2c_ftnlen_one_node,
12786                                                build_int_2 (size, 0)));
12787   if (elements != -1)
12788     type = build_array_type (type,
12789                              build_range_type (integer_type_node,
12790                                                integer_zero_node,
12791                                                build_int_2 (elements - 1,
12792                                                             0)));
12793   t = build_decl (VAR_DECL,
12794                   ffecom_get_invented_identifier ("__g77_%s_%d",
12795                                                   commentary,
12796                                                   mynumber++),
12797                   type);
12798
12799   t = start_decl (t, FALSE);
12800   finish_decl (t, NULL_TREE, FALSE);
12801
12802   resume_momentary (yes);
12803
12804   return t;
12805 }
12806 #endif
12807
12808 /* Prepare argument pointer to expression.
12809
12810    Like ffecom_prepare_expr, except for expressions to be evaluated
12811    via ffecom_arg_ptr_to_expr.  */
12812
12813 void
12814 ffecom_prepare_arg_ptr_to_expr (ffebld expr)
12815 {
12816   /* ~~For now, it seems to be the same thing.  */
12817   ffecom_prepare_expr (expr);
12818   return;
12819 }
12820
12821 /* End of preparations.  */
12822
12823 bool
12824 ffecom_prepare_end (void)
12825 {
12826   int prep_state = current_binding_level->prep_state;
12827
12828   assert (prep_state < 2);
12829   current_binding_level->prep_state = 2;
12830
12831   return (prep_state == 1) ? TRUE : FALSE;
12832 }
12833
12834 /* Prepare expression.
12835
12836    This is called before any code is generated for the current block.
12837    It scans the expression, declares any temporaries that might be needed
12838    during evaluation of the expression, and stores those temporaries in
12839    the appropriate "hook" fields of the expression.  `dest', if not NULL,
12840    specifies the destination that ffecom_expr_ will see, in case that
12841    helps avoid generating unused temporaries.
12842
12843    ~~Improve to avoid allocating unused temporaries by taking `dest'
12844    into account vis-a-vis aliasing requirements of complex/character
12845    functions.  */
12846
12847 void
12848 ffecom_prepare_expr_ (ffebld expr, ffebld dest UNUSED)
12849 {
12850   ffeinfoBasictype bt;
12851   ffeinfoKindtype kt;
12852   ffetargetCharacterSize sz;
12853   tree tempvar = NULL_TREE;
12854
12855   assert (current_binding_level->prep_state < 2);
12856
12857   if (! expr)
12858     return;
12859
12860   bt = ffeinfo_basictype (ffebld_info (expr));
12861   kt = ffeinfo_kindtype (ffebld_info (expr));
12862   sz = ffeinfo_size (ffebld_info (expr));
12863
12864   /* Generate whatever temporaries are needed to represent the result
12865      of the expression.  */
12866
12867   if (bt == FFEINFO_basictypeCHARACTER)
12868     {
12869       while (ffebld_op (expr) == FFEBLD_opPAREN)
12870         expr = ffebld_left (expr);
12871     }
12872
12873   switch (ffebld_op (expr))
12874     {
12875     default:
12876       /* Don't make temps for SYMTER, CONTER, etc.  */
12877       if (ffebld_arity (expr) == 0)
12878         break;
12879
12880       switch (bt)
12881         {
12882         case FFEINFO_basictypeCOMPLEX:
12883           if (ffebld_op (expr) == FFEBLD_opFUNCREF)
12884             {
12885               ffesymbol s;
12886
12887               if (ffebld_op (ffebld_left (expr)) != FFEBLD_opSYMTER)
12888                 break;
12889
12890               s = ffebld_symter (ffebld_left (expr));
12891               if (ffesymbol_where (s) == FFEINFO_whereCONSTANT
12892                   || (ffesymbol_where (s) != FFEINFO_whereINTRINSIC
12893                       && ! ffesymbol_is_f2c (s))
12894                   || (ffesymbol_where (s) == FFEINFO_whereINTRINSIC
12895                       && ! ffe_is_f2c_library ()))
12896                 break;
12897             }
12898           else if (ffebld_op (expr) == FFEBLD_opPOWER)
12899             {
12900               /* Requires special treatment.  There's no POW_CC function
12901                  in libg2c, so POW_ZZ is used, which means we always
12902                  need a double-complex temp, not a single-complex.  */
12903               kt = FFEINFO_kindtypeREAL2;
12904             }
12905           else if (ffebld_op (expr) != FFEBLD_opDIVIDE)
12906             /* The other ops don't need temps for complex operands.  */
12907             break;
12908
12909           /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
12910              REAL(C).  See 19990325-0.f, routine `check', for cases.  */
12911           tempvar = ffecom_make_tempvar ("complex",
12912                                          ffecom_tree_type
12913                                          [FFEINFO_basictypeCOMPLEX][kt],
12914                                          FFETARGET_charactersizeNONE,
12915                                          -1);
12916           break;
12917
12918         case FFEINFO_basictypeCHARACTER:
12919           if (ffebld_op (expr) != FFEBLD_opFUNCREF)
12920             break;
12921
12922           if (sz == FFETARGET_charactersizeNONE)
12923             /* ~~Kludge alert!  This should someday be fixed. */
12924             sz = 24;
12925
12926           tempvar = ffecom_make_tempvar ("char", char_type_node, sz, -1);
12927           break;
12928
12929         default:
12930           break;
12931         }
12932       break;
12933
12934 #ifdef HAHA
12935     case FFEBLD_opPOWER:
12936       {
12937         tree rtype, ltype;
12938         tree rtmp, ltmp, result;
12939
12940         ltype = ffecom_type_expr (ffebld_left (expr));
12941         rtype = ffecom_type_expr (ffebld_right (expr));
12942
12943         rtmp = ffecom_make_tempvar (rtype, FFETARGET_charactersizeNONE, -1);
12944         ltmp = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12945         result = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12946
12947         tempvar = make_tree_vec (3);
12948         TREE_VEC_ELT (tempvar, 0) = rtmp;
12949         TREE_VEC_ELT (tempvar, 1) = ltmp;
12950         TREE_VEC_ELT (tempvar, 2) = result;
12951       }
12952       break;
12953 #endif  /* HAHA */
12954
12955     case FFEBLD_opCONCATENATE:
12956       {
12957         /* This gets special handling, because only one set of temps
12958            is needed for a tree of these -- the tree is treated as
12959            a flattened list of concatenations when generating code.  */
12960
12961         ffecomConcatList_ catlist;
12962         tree ltmp, itmp, result;
12963         int count;
12964         int i;
12965
12966         catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
12967         count = ffecom_concat_list_count_ (catlist);
12968
12969         if (count >= 2)
12970           {
12971             ltmp
12972               = ffecom_make_tempvar ("concat_len",
12973                                      ffecom_f2c_ftnlen_type_node,
12974                                      FFETARGET_charactersizeNONE, count);
12975             itmp
12976               = ffecom_make_tempvar ("concat_item",
12977                                      ffecom_f2c_address_type_node,
12978                                      FFETARGET_charactersizeNONE, count);
12979             result
12980               = ffecom_make_tempvar ("concat_res",
12981                                      char_type_node,
12982                                      ffecom_concat_list_maxlen_ (catlist),
12983                                      -1);
12984
12985             tempvar = make_tree_vec (3);
12986             TREE_VEC_ELT (tempvar, 0) = ltmp;
12987             TREE_VEC_ELT (tempvar, 1) = itmp;
12988             TREE_VEC_ELT (tempvar, 2) = result;
12989           }
12990
12991         for (i = 0; i < count; ++i)
12992           ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist,
12993                                                                     i));
12994
12995         ffecom_concat_list_kill_ (catlist);
12996
12997         if (tempvar)
12998           {
12999             ffebld_nonter_set_hook (expr, tempvar);
13000             current_binding_level->prep_state = 1;
13001           }
13002       }
13003       return;
13004
13005     case FFEBLD_opCONVERT:
13006       if (bt == FFEINFO_basictypeCHARACTER
13007           && ((ffebld_size_known (ffebld_left (expr))
13008                == FFETARGET_charactersizeNONE)
13009               || (ffebld_size_known (ffebld_left (expr)) >= sz)))
13010         tempvar = ffecom_make_tempvar ("convert", char_type_node, sz, -1);
13011       break;
13012     }
13013
13014   if (tempvar)
13015     {
13016       ffebld_nonter_set_hook (expr, tempvar);
13017       current_binding_level->prep_state = 1;
13018     }
13019
13020   /* Prepare subexpressions for this expr.  */
13021
13022   switch (ffebld_op (expr))
13023     {
13024     case FFEBLD_opPERCENT_LOC:
13025       ffecom_prepare_ptr_to_expr (ffebld_left (expr));
13026       break;
13027
13028     case FFEBLD_opPERCENT_VAL:
13029     case FFEBLD_opPERCENT_REF:
13030       ffecom_prepare_expr (ffebld_left (expr));
13031       break;
13032
13033     case FFEBLD_opPERCENT_DESCR:
13034       ffecom_prepare_arg_ptr_to_expr (ffebld_left (expr));
13035       break;
13036
13037     case FFEBLD_opITEM:
13038       {
13039         ffebld item;
13040
13041         for (item = expr;
13042              item != NULL;
13043              item = ffebld_trail (item))
13044           if (ffebld_head (item) != NULL)
13045             ffecom_prepare_expr (ffebld_head (item));
13046       }
13047       break;
13048
13049     default:
13050       /* Need to handle character conversion specially.  */
13051       switch (ffebld_arity (expr))
13052         {
13053         case 2:
13054           ffecom_prepare_expr (ffebld_left (expr));
13055           ffecom_prepare_expr (ffebld_right (expr));
13056           break;
13057
13058         case 1:
13059           ffecom_prepare_expr (ffebld_left (expr));
13060           break;
13061
13062         default:
13063           break;
13064         }
13065     }
13066
13067   return;
13068 }
13069
13070 /* Prepare expression for reading and writing.
13071
13072    Like ffecom_prepare_expr, except for expressions to be evaluated
13073    via ffecom_expr_rw.  */
13074
13075 void
13076 ffecom_prepare_expr_rw (tree type, ffebld expr)
13077 {
13078   /* This is all we support for now.  */
13079   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
13080
13081   /* ~~For now, it seems to be the same thing.  */
13082   ffecom_prepare_expr (expr);
13083   return;
13084 }
13085
13086 /* Prepare expression for writing.
13087
13088    Like ffecom_prepare_expr, except for expressions to be evaluated
13089    via ffecom_expr_w.  */
13090
13091 void
13092 ffecom_prepare_expr_w (tree type, ffebld expr)
13093 {
13094   /* This is all we support for now.  */
13095   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
13096
13097   /* ~~For now, it seems to be the same thing.  */
13098   ffecom_prepare_expr (expr);
13099   return;
13100 }
13101
13102 /* Prepare expression for returning.
13103
13104    Like ffecom_prepare_expr, except for expressions to be evaluated
13105    via ffecom_return_expr.  */
13106
13107 void
13108 ffecom_prepare_return_expr (ffebld expr)
13109 {
13110   assert (current_binding_level->prep_state < 2);
13111
13112   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE
13113       && ffecom_is_altreturning_
13114       && expr != NULL)
13115     ffecom_prepare_expr (expr);
13116 }
13117
13118 /* Prepare pointer to expression.
13119
13120    Like ffecom_prepare_expr, except for expressions to be evaluated
13121    via ffecom_ptr_to_expr.  */
13122
13123 void
13124 ffecom_prepare_ptr_to_expr (ffebld expr)
13125 {
13126   /* ~~For now, it seems to be the same thing.  */
13127   ffecom_prepare_expr (expr);
13128   return;
13129 }
13130
13131 /* Transform expression into constant pointer-to-expression tree.
13132
13133    If the expression can be transformed into a pointer-to-expression tree
13134    that is constant, that is done, and the tree returned.  Else NULL_TREE
13135    is returned.
13136
13137    That way, a caller can attempt to provide compile-time initialization
13138    of a variable and, if that fails, *then* choose to start a new block
13139    and resort to using temporaries, as appropriate.  */
13140
13141 tree
13142 ffecom_ptr_to_const_expr (ffebld expr)
13143 {
13144   if (! expr)
13145     return integer_zero_node;
13146
13147   if (ffebld_op (expr) == FFEBLD_opANY)
13148     return error_mark_node;
13149
13150   if (ffebld_arity (expr) == 0
13151       && (ffebld_op (expr) != FFEBLD_opSYMTER
13152           || ffebld_where (expr) == FFEINFO_whereCOMMON
13153           || ffebld_where (expr) == FFEINFO_whereGLOBAL
13154           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
13155     {
13156       tree t;
13157
13158       t = ffecom_ptr_to_expr (expr);
13159       assert (TREE_CONSTANT (t));
13160       return t;
13161     }
13162
13163   return NULL_TREE;
13164 }
13165
13166 /* ffecom_return_expr -- Returns return-value expr given alt return expr
13167
13168    tree rtn;  // NULL_TREE means use expand_null_return()
13169    ffebld expr;  // NULL if no alt return expr to RETURN stmt
13170    rtn = ffecom_return_expr(expr);
13171
13172    Based on the program unit type and other info (like return function
13173    type, return master function type when alternate ENTRY points,
13174    whether subroutine has any alternate RETURN points, etc), returns the
13175    appropriate expression to be returned to the caller, or NULL_TREE
13176    meaning no return value or the caller expects it to be returned somewhere
13177    else (which is handled by other parts of this module).  */
13178
13179 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13180 tree
13181 ffecom_return_expr (ffebld expr)
13182 {
13183   tree rtn;
13184
13185   switch (ffecom_primary_entry_kind_)
13186     {
13187     case FFEINFO_kindPROGRAM:
13188     case FFEINFO_kindBLOCKDATA:
13189       rtn = NULL_TREE;
13190       break;
13191
13192     case FFEINFO_kindSUBROUTINE:
13193       if (!ffecom_is_altreturning_)
13194         rtn = NULL_TREE;        /* No alt returns, never an expr. */
13195       else if (expr == NULL)
13196         rtn = integer_zero_node;
13197       else
13198         rtn = ffecom_expr (expr);
13199       break;
13200
13201     case FFEINFO_kindFUNCTION:
13202       if ((ffecom_multi_retval_ != NULL_TREE)
13203           || (ffesymbol_basictype (ffecom_primary_entry_)
13204               == FFEINFO_basictypeCHARACTER)
13205           || ((ffesymbol_basictype (ffecom_primary_entry_)
13206                == FFEINFO_basictypeCOMPLEX)
13207               && (ffecom_num_entrypoints_ == 0)
13208               && ffesymbol_is_f2c (ffecom_primary_entry_)))
13209         {                       /* Value is returned by direct assignment
13210                                    into (implicit) dummy. */
13211           rtn = NULL_TREE;
13212           break;
13213         }
13214       rtn = ffecom_func_result_;
13215 #if 0
13216       /* Spurious error if RETURN happens before first reference!  So elide
13217          this code.  In particular, for debugging registry, rtn should always
13218          be non-null after all, but TREE_USED won't be set until we encounter
13219          a reference in the code.  Perfectly okay (but weird) code that,
13220          e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
13221          this diagnostic for no reason.  Have people use -O -Wuninitialized
13222          and leave it to the back end to find obviously weird cases.  */
13223
13224       /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
13225          situation; if the return value has never been referenced, it won't
13226          have a tree under 2pass mode. */
13227       if ((rtn == NULL_TREE)
13228           || !TREE_USED (rtn))
13229         {
13230           ffebad_start (FFEBAD_RETURN_VALUE_UNSET);
13231           ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_),
13232                        ffesymbol_where_column (ffecom_primary_entry_));
13233           ffebad_string (ffesymbol_text (ffesymbol_funcresult
13234                                          (ffecom_primary_entry_)));
13235           ffebad_finish ();
13236         }
13237 #endif
13238       break;
13239
13240     default:
13241       assert ("bad unit kind" == NULL);
13242     case FFEINFO_kindANY:
13243       rtn = error_mark_node;
13244       break;
13245     }
13246
13247   return rtn;
13248 }
13249
13250 #endif
13251 /* Do save_expr only if tree is not error_mark_node.  */
13252
13253 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13254 tree
13255 ffecom_save_tree (tree t)
13256 {
13257   return save_expr (t);
13258 }
13259 #endif
13260
13261 /* Start a compound statement (block).  */
13262
13263 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13264 void
13265 ffecom_start_compstmt (void)
13266 {
13267   bison_rule_pushlevel_ ();
13268 }
13269 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
13270
13271 /* Public entry point for front end to access start_decl.  */
13272
13273 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13274 tree
13275 ffecom_start_decl (tree decl, bool is_initialized)
13276 {
13277   DECL_INITIAL (decl) = is_initialized ? error_mark_node : NULL_TREE;
13278   return start_decl (decl, FALSE);
13279 }
13280
13281 #endif
13282 /* ffecom_sym_commit -- Symbol's state being committed to reality
13283
13284    ffesymbol s;
13285    ffecom_sym_commit(s);
13286
13287    Does whatever the backend needs when a symbol is committed after having
13288    been backtrackable for a period of time.  */
13289
13290 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13291 void
13292 ffecom_sym_commit (ffesymbol s UNUSED)
13293 {
13294   assert (!ffesymbol_retractable ());
13295 }
13296
13297 #endif
13298 /* ffecom_sym_end_transition -- Perform end transition on all symbols
13299
13300    ffecom_sym_end_transition();
13301
13302    Does backend-specific stuff and also calls ffest_sym_end_transition
13303    to do the necessary FFE stuff.
13304
13305    Backtracking is never enabled when this fn is called, so don't worry
13306    about it.  */
13307
13308 ffesymbol
13309 ffecom_sym_end_transition (ffesymbol s)
13310 {
13311   ffestorag st;
13312
13313   assert (!ffesymbol_retractable ());
13314
13315   s = ffest_sym_end_transition (s);
13316
13317 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13318   if ((ffesymbol_kind (s) == FFEINFO_kindBLOCKDATA)
13319       && (ffesymbol_where (s) == FFEINFO_whereGLOBAL))
13320     {
13321       ffecom_list_blockdata_
13322         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
13323                                               FFEINTRIN_specNONE,
13324                                               FFEINTRIN_impNONE),
13325                            ffecom_list_blockdata_);
13326     }
13327 #endif
13328
13329   /* This is where we finally notice that a symbol has partial initialization
13330      and finalize it. */
13331
13332   if (ffesymbol_accretion (s) != NULL)
13333     {
13334       assert (ffesymbol_init (s) == NULL);
13335       ffecom_notify_init_symbol (s);
13336     }
13337   else if (((st = ffesymbol_storage (s)) != NULL)
13338            && ((st = ffestorag_parent (st)) != NULL)
13339            && (ffestorag_accretion (st) != NULL))
13340     {
13341       assert (ffestorag_init (st) == NULL);
13342       ffecom_notify_init_storage (st);
13343     }
13344
13345 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13346   if ((ffesymbol_kind (s) == FFEINFO_kindCOMMON)
13347       && (ffesymbol_where (s) == FFEINFO_whereLOCAL)
13348       && (ffesymbol_storage (s) != NULL))
13349     {
13350       ffecom_list_common_
13351         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
13352                                               FFEINTRIN_specNONE,
13353                                               FFEINTRIN_impNONE),
13354                            ffecom_list_common_);
13355     }
13356 #endif
13357
13358   return s;
13359 }
13360
13361 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
13362
13363    ffecom_sym_exec_transition();
13364
13365    Does backend-specific stuff and also calls ffest_sym_exec_transition
13366    to do the necessary FFE stuff.
13367
13368    See the long-winded description in ffecom_sym_learned for info
13369    on handling the situation where backtracking is inhibited.  */
13370
13371 ffesymbol
13372 ffecom_sym_exec_transition (ffesymbol s)
13373 {
13374   s = ffest_sym_exec_transition (s);
13375
13376   return s;
13377 }
13378
13379 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
13380
13381    ffesymbol s;
13382    s = ffecom_sym_learned(s);
13383
13384    Called when a new symbol is seen after the exec transition or when more
13385    info (perhaps) is gained for an UNCERTAIN symbol.  The symbol state when
13386    it arrives here is that all its latest info is updated already, so its
13387    state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
13388    field filled in if its gone through here or exec_transition first, and
13389    so on.
13390
13391    The backend probably wants to check ffesymbol_retractable() to see if
13392    backtracking is in effect.  If so, the FFE's changes to the symbol may
13393    be retracted (undone) or committed (ratified), at which time the
13394    appropriate ffecom_sym_retract or _commit function will be called
13395    for that function.
13396
13397    If the backend has its own backtracking mechanism, great, use it so that
13398    committal is a simple operation.  Though it doesn't make much difference,
13399    I suppose: the reason for tentative symbol evolution in the FFE is to
13400    enable error detection in weird incorrect statements early and to disable
13401    incorrect error detection on a correct statement.  The backend is not
13402    likely to introduce any information that'll get involved in these
13403    considerations, so it is probably just fine that the implementation
13404    model for this fn and for _exec_transition is to not do anything
13405    (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
13406    and instead wait until ffecom_sym_commit is called (which it never
13407    will be as long as we're using ambiguity-detecting statement analysis in
13408    the FFE, which we are initially to shake out the code, but don't depend
13409    on this), otherwise go ahead and do whatever is needed.
13410
13411    In essence, then, when this fn and _exec_transition get called while
13412    backtracking is enabled, a general mechanism would be to flag which (or
13413    both) of these were called (and in what order? neat question as to what
13414    might happen that I'm too lame to think through right now) and then when
13415    _commit is called reproduce the original calling sequence, if any, for
13416    the two fns (at which point backtracking will, of course, be disabled).  */
13417
13418 ffesymbol
13419 ffecom_sym_learned (ffesymbol s)
13420 {
13421   ffestorag_exec_layout (s);
13422
13423   return s;
13424 }
13425
13426 /* ffecom_sym_retract -- Symbol's state being retracted from reality
13427
13428    ffesymbol s;
13429    ffecom_sym_retract(s);
13430
13431    Does whatever the backend needs when a symbol is retracted after having
13432    been backtrackable for a period of time.  */
13433
13434 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13435 void
13436 ffecom_sym_retract (ffesymbol s UNUSED)
13437 {
13438   assert (!ffesymbol_retractable ());
13439
13440 #if 0                           /* GCC doesn't commit any backtrackable sins,
13441                                    so nothing needed here. */
13442   switch (ffesymbol_hook (s).state)
13443     {
13444     case 0:                     /* nothing happened yet. */
13445       break;
13446
13447     case 1:                     /* exec transition happened. */
13448       break;
13449
13450     case 2:                     /* learned happened. */
13451       break;
13452
13453     case 3:                     /* learned then exec. */
13454       break;
13455
13456     case 4:                     /* exec then learned. */
13457       break;
13458
13459     default:
13460       assert ("bad hook state" == NULL);
13461       break;
13462     }
13463 #endif
13464 }
13465
13466 #endif
13467 /* Create temporary gcc label.  */
13468
13469 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13470 tree
13471 ffecom_temp_label ()
13472 {
13473   tree glabel;
13474   static int mynumber = 0;
13475
13476   glabel = build_decl (LABEL_DECL,
13477                        ffecom_get_invented_identifier ("__g77_label_%d",
13478                                                        mynumber++),
13479                        void_type_node);
13480   DECL_CONTEXT (glabel) = current_function_decl;
13481   DECL_MODE (glabel) = VOIDmode;
13482
13483   return glabel;
13484 }
13485
13486 #endif
13487 /* Return an expression that is usable as an arg in a conditional context
13488    (IF, DO WHILE, .NOT., and so on).
13489
13490    Use the one provided for the back end as of >2.6.0.  */
13491
13492 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13493 tree
13494 ffecom_truth_value (tree expr)
13495 {
13496   return truthvalue_conversion (expr);
13497 }
13498
13499 #endif
13500 /* Return the inversion of a truth value (the inversion of what
13501    ffecom_truth_value builds).
13502
13503    Apparently invert_truthvalue, which is properly in the back end, is
13504    enough for now, so just use it.  */
13505
13506 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13507 tree
13508 ffecom_truth_value_invert (tree expr)
13509 {
13510   return invert_truthvalue (ffecom_truth_value (expr));
13511 }
13512
13513 #endif
13514
13515 /* Return the tree that is the type of the expression, as would be
13516    returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
13517    transforming the expression, generating temporaries, etc.  */
13518
13519 tree
13520 ffecom_type_expr (ffebld expr)
13521 {
13522   ffeinfoBasictype bt;
13523   ffeinfoKindtype kt;
13524   tree tree_type;
13525
13526   assert (expr != NULL);
13527
13528   bt = ffeinfo_basictype (ffebld_info (expr));
13529   kt = ffeinfo_kindtype (ffebld_info (expr));
13530   tree_type = ffecom_tree_type[bt][kt];
13531
13532   switch (ffebld_op (expr))
13533     {
13534     case FFEBLD_opCONTER:
13535     case FFEBLD_opSYMTER:
13536     case FFEBLD_opARRAYREF:
13537     case FFEBLD_opUPLUS:
13538     case FFEBLD_opPAREN:
13539     case FFEBLD_opUMINUS:
13540     case FFEBLD_opADD:
13541     case FFEBLD_opSUBTRACT:
13542     case FFEBLD_opMULTIPLY:
13543     case FFEBLD_opDIVIDE:
13544     case FFEBLD_opPOWER:
13545     case FFEBLD_opNOT:
13546     case FFEBLD_opFUNCREF:
13547     case FFEBLD_opSUBRREF:
13548     case FFEBLD_opAND:
13549     case FFEBLD_opOR:
13550     case FFEBLD_opXOR:
13551     case FFEBLD_opNEQV:
13552     case FFEBLD_opEQV:
13553     case FFEBLD_opCONVERT:
13554     case FFEBLD_opLT:
13555     case FFEBLD_opLE:
13556     case FFEBLD_opEQ:
13557     case FFEBLD_opNE:
13558     case FFEBLD_opGT:
13559     case FFEBLD_opGE:
13560     case FFEBLD_opPERCENT_LOC:
13561       return tree_type;
13562
13563     case FFEBLD_opACCTER:
13564     case FFEBLD_opARRTER:
13565     case FFEBLD_opITEM:
13566     case FFEBLD_opSTAR:
13567     case FFEBLD_opBOUNDS:
13568     case FFEBLD_opREPEAT:
13569     case FFEBLD_opLABTER:
13570     case FFEBLD_opLABTOK:
13571     case FFEBLD_opIMPDO:
13572     case FFEBLD_opCONCATENATE:
13573     case FFEBLD_opSUBSTR:
13574     default:
13575       assert ("bad op for ffecom_type_expr" == NULL);
13576       /* Fall through. */
13577     case FFEBLD_opANY:
13578       return error_mark_node;
13579     }
13580 }
13581
13582 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13583
13584    If the PARM_DECL already exists, return it, else create it.  It's an
13585    integer_type_node argument for the master function that implements a
13586    subroutine or function with more than one entrypoint and is bound at
13587    run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13588    first ENTRY statement, and so on).  */
13589
13590 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13591 tree
13592 ffecom_which_entrypoint_decl ()
13593 {
13594   assert (ffecom_which_entrypoint_decl_ != NULL_TREE);
13595
13596   return ffecom_which_entrypoint_decl_;
13597 }
13598
13599 #endif
13600 \f
13601 /* The following sections consists of private and public functions
13602    that have the same names and perform roughly the same functions
13603    as counterparts in the C front end.  Changes in the C front end
13604    might affect how things should be done here.  Only functions
13605    needed by the back end should be public here; the rest should
13606    be private (static in the C sense).  Functions needed by other
13607    g77 front-end modules should be accessed by them via public
13608    ffecom_* names, which should themselves call private versions
13609    in this section so the private versions are easy to recognize
13610    when upgrading to a new gcc and finding interesting changes
13611    in the front end.
13612
13613    Functions named after rule "foo:" in c-parse.y are named
13614    "bison_rule_foo_" so they are easy to find.  */
13615
13616 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13617
13618 static void
13619 bison_rule_pushlevel_ ()
13620 {
13621   emit_line_note (input_filename, lineno);
13622   pushlevel (0);
13623   clear_last_expr ();
13624   push_momentary ();
13625   expand_start_bindings (0);
13626 }
13627
13628 static tree
13629 bison_rule_compstmt_ ()
13630 {
13631   tree t;
13632   int keep = kept_level_p ();
13633
13634   /* Make the temps go away.  */
13635   if (! keep)
13636     current_binding_level->names = NULL_TREE;
13637
13638   emit_line_note (input_filename, lineno);
13639   expand_end_bindings (getdecls (), keep, 0);
13640   t = poplevel (keep, 1, 0);
13641   pop_momentary ();
13642
13643   return t;
13644 }
13645
13646 /* Return a definition for a builtin function named NAME and whose data type
13647    is TYPE.  TYPE should be a function type with argument types.
13648    FUNCTION_CODE tells later passes how to compile calls to this function.
13649    See tree.h for its possible values.
13650
13651    If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13652    the name to be called if we can't opencode the function.  */
13653
13654 tree
13655 builtin_function (const char *name, tree type, int function_code,
13656                   enum built_in_class class,
13657                   const char *library_name)
13658 {
13659   tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
13660   DECL_EXTERNAL (decl) = 1;
13661   TREE_PUBLIC (decl) = 1;
13662   if (library_name)
13663     DECL_ASSEMBLER_NAME (decl) = get_identifier (library_name);
13664   make_decl_rtl (decl, NULL_PTR, 1);
13665   pushdecl (decl);
13666   DECL_BUILT_IN_CLASS (decl) = class;
13667   DECL_FUNCTION_CODE (decl) = function_code;
13668
13669   return decl;
13670 }
13671
13672 /* Handle when a new declaration NEWDECL
13673    has the same name as an old one OLDDECL
13674    in the same binding contour.
13675    Prints an error message if appropriate.
13676
13677    If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13678    Otherwise, return 0.  */
13679
13680 static int
13681 duplicate_decls (tree newdecl, tree olddecl)
13682 {
13683   int types_match = 1;
13684   int new_is_definition = (TREE_CODE (newdecl) == FUNCTION_DECL
13685                            && DECL_INITIAL (newdecl) != 0);
13686   tree oldtype = TREE_TYPE (olddecl);
13687   tree newtype = TREE_TYPE (newdecl);
13688
13689   if (olddecl == newdecl)
13690     return 1;
13691
13692   if (TREE_CODE (newtype) == ERROR_MARK
13693       || TREE_CODE (oldtype) == ERROR_MARK)
13694     types_match = 0;
13695
13696   /* New decl is completely inconsistent with the old one =>
13697      tell caller to replace the old one.
13698      This is always an error except in the case of shadowing a builtin.  */
13699   if (TREE_CODE (olddecl) != TREE_CODE (newdecl))
13700     return 0;
13701
13702   /* For real parm decl following a forward decl,
13703      return 1 so old decl will be reused.  */
13704   if (types_match && TREE_CODE (newdecl) == PARM_DECL
13705       && TREE_ASM_WRITTEN (olddecl) && ! TREE_ASM_WRITTEN (newdecl))
13706     return 1;
13707
13708   /* The new declaration is the same kind of object as the old one.
13709      The declarations may partially match.  Print warnings if they don't
13710      match enough.  Ultimately, copy most of the information from the new
13711      decl to the old one, and keep using the old one.  */
13712
13713   if (TREE_CODE (olddecl) == FUNCTION_DECL
13714       && DECL_BUILT_IN (olddecl))
13715     {
13716       /* A function declaration for a built-in function.  */
13717       if (!TREE_PUBLIC (newdecl))
13718         return 0;
13719       else if (!types_match)
13720         {
13721           /* Accept the return type of the new declaration if same modes.  */
13722           tree oldreturntype = TREE_TYPE (TREE_TYPE (olddecl));
13723           tree newreturntype = TREE_TYPE (TREE_TYPE (newdecl));
13724
13725           if (TYPE_MODE (oldreturntype) == TYPE_MODE (newreturntype))
13726             {
13727               /* Function types may be shared, so we can't just modify
13728                  the return type of olddecl's function type.  */
13729               tree newtype
13730                 = build_function_type (newreturntype,
13731                                        TYPE_ARG_TYPES (TREE_TYPE (olddecl)));
13732
13733               types_match = 1;
13734               if (types_match)
13735                 TREE_TYPE (olddecl) = newtype;
13736             }
13737         }
13738       if (!types_match)
13739         return 0;
13740     }
13741   else if (TREE_CODE (olddecl) == FUNCTION_DECL
13742            && DECL_SOURCE_LINE (olddecl) == 0)
13743     {
13744       /* A function declaration for a predeclared function
13745          that isn't actually built in.  */
13746       if (!TREE_PUBLIC (newdecl))
13747         return 0;
13748       else if (!types_match)
13749         {
13750           /* If the types don't match, preserve volatility indication.
13751              Later on, we will discard everything else about the
13752              default declaration.  */
13753           TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl);
13754         }
13755     }
13756
13757   /* Copy all the DECL_... slots specified in the new decl
13758      except for any that we copy here from the old type.
13759
13760      Past this point, we don't change OLDTYPE and NEWTYPE
13761      even if we change the types of NEWDECL and OLDDECL.  */
13762
13763   if (types_match)
13764     {
13765       /* Merge the data types specified in the two decls.  */
13766       if (TREE_CODE (newdecl) != FUNCTION_DECL || !DECL_BUILT_IN (olddecl))
13767         TREE_TYPE (newdecl)
13768           = TREE_TYPE (olddecl)
13769             = TREE_TYPE (newdecl);
13770
13771       /* Lay the type out, unless already done.  */
13772       if (oldtype != TREE_TYPE (newdecl))
13773         {
13774           if (TREE_TYPE (newdecl) != error_mark_node)
13775             layout_type (TREE_TYPE (newdecl));
13776           if (TREE_CODE (newdecl) != FUNCTION_DECL
13777               && TREE_CODE (newdecl) != TYPE_DECL
13778               && TREE_CODE (newdecl) != CONST_DECL)
13779             layout_decl (newdecl, 0);
13780         }
13781       else
13782         {
13783           /* Since the type is OLDDECL's, make OLDDECL's size go with.  */
13784           DECL_SIZE (newdecl) = DECL_SIZE (olddecl);
13785           DECL_SIZE_UNIT (newdecl) = DECL_SIZE_UNIT (olddecl);
13786           if (TREE_CODE (olddecl) != FUNCTION_DECL)
13787             if (DECL_ALIGN (olddecl) > DECL_ALIGN (newdecl))
13788               DECL_ALIGN (newdecl) = DECL_ALIGN (olddecl);
13789         }
13790
13791       /* Keep the old rtl since we can safely use it.  */
13792       DECL_RTL (newdecl) = DECL_RTL (olddecl);
13793
13794       /* Merge the type qualifiers.  */
13795       if (DECL_BUILT_IN_NONANSI (olddecl) && TREE_THIS_VOLATILE (olddecl)
13796           && !TREE_THIS_VOLATILE (newdecl))
13797         TREE_THIS_VOLATILE (olddecl) = 0;
13798       if (TREE_READONLY (newdecl))
13799         TREE_READONLY (olddecl) = 1;
13800       if (TREE_THIS_VOLATILE (newdecl))
13801         {
13802           TREE_THIS_VOLATILE (olddecl) = 1;
13803           if (TREE_CODE (newdecl) == VAR_DECL)
13804             make_var_volatile (newdecl);
13805         }
13806
13807       /* Keep source location of definition rather than declaration.
13808          Likewise, keep decl at outer scope.  */
13809       if ((DECL_INITIAL (newdecl) == 0 && DECL_INITIAL (olddecl) != 0)
13810           || (DECL_CONTEXT (newdecl) != 0 && DECL_CONTEXT (olddecl) == 0))
13811         {
13812           DECL_SOURCE_LINE (newdecl) = DECL_SOURCE_LINE (olddecl);
13813           DECL_SOURCE_FILE (newdecl) = DECL_SOURCE_FILE (olddecl);
13814
13815           if (DECL_CONTEXT (olddecl) == 0
13816               && TREE_CODE (newdecl) != FUNCTION_DECL)
13817             DECL_CONTEXT (newdecl) = 0;
13818         }
13819
13820       /* Merge the unused-warning information.  */
13821       if (DECL_IN_SYSTEM_HEADER (olddecl))
13822         DECL_IN_SYSTEM_HEADER (newdecl) = 1;
13823       else if (DECL_IN_SYSTEM_HEADER (newdecl))
13824         DECL_IN_SYSTEM_HEADER (olddecl) = 1;
13825
13826       /* Merge the initialization information.  */
13827       if (DECL_INITIAL (newdecl) == 0)
13828         DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13829
13830       /* Merge the section attribute.
13831          We want to issue an error if the sections conflict but that must be
13832          done later in decl_attributes since we are called before attributes
13833          are assigned.  */
13834       if (DECL_SECTION_NAME (newdecl) == NULL_TREE)
13835         DECL_SECTION_NAME (newdecl) = DECL_SECTION_NAME (olddecl);
13836
13837 #if BUILT_FOR_270
13838       if (TREE_CODE (newdecl) == FUNCTION_DECL)
13839         {
13840           DECL_STATIC_CONSTRUCTOR(newdecl) |= DECL_STATIC_CONSTRUCTOR(olddecl);
13841           DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl);
13842         }
13843 #endif
13844     }
13845   /* If cannot merge, then use the new type and qualifiers,
13846      and don't preserve the old rtl.  */
13847   else
13848     {
13849       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13850       TREE_READONLY (olddecl) = TREE_READONLY (newdecl);
13851       TREE_THIS_VOLATILE (olddecl) = TREE_THIS_VOLATILE (newdecl);
13852       TREE_SIDE_EFFECTS (olddecl) = TREE_SIDE_EFFECTS (newdecl);
13853     }
13854
13855   /* Merge the storage class information.  */
13856   /* For functions, static overrides non-static.  */
13857   if (TREE_CODE (newdecl) == FUNCTION_DECL)
13858     {
13859       TREE_PUBLIC (newdecl) &= TREE_PUBLIC (olddecl);
13860       /* This is since we don't automatically
13861          copy the attributes of NEWDECL into OLDDECL.  */
13862       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13863       /* If this clears `static', clear it in the identifier too.  */
13864       if (! TREE_PUBLIC (olddecl))
13865         TREE_PUBLIC (DECL_NAME (olddecl)) = 0;
13866     }
13867   if (DECL_EXTERNAL (newdecl))
13868     {
13869       TREE_STATIC (newdecl) = TREE_STATIC (olddecl);
13870       DECL_EXTERNAL (newdecl) = DECL_EXTERNAL (olddecl);
13871       /* An extern decl does not override previous storage class.  */
13872       TREE_PUBLIC (newdecl) = TREE_PUBLIC (olddecl);
13873     }
13874   else
13875     {
13876       TREE_STATIC (olddecl) = TREE_STATIC (newdecl);
13877       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13878     }
13879
13880   /* If either decl says `inline', this fn is inline,
13881      unless its definition was passed already.  */
13882   if (DECL_INLINE (newdecl) && DECL_INITIAL (olddecl) == 0)
13883     DECL_INLINE (olddecl) = 1;
13884   DECL_INLINE (newdecl) = DECL_INLINE (olddecl);
13885
13886   /* Get rid of any built-in function if new arg types don't match it
13887      or if we have a function definition.  */
13888   if (TREE_CODE (newdecl) == FUNCTION_DECL
13889       && DECL_BUILT_IN (olddecl)
13890       && (!types_match || new_is_definition))
13891     {
13892       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13893       DECL_BUILT_IN_CLASS (olddecl) = NOT_BUILT_IN;
13894     }
13895
13896   /* If redeclaring a builtin function, and not a definition,
13897      it stays built in.
13898      Also preserve various other info from the definition.  */
13899   if (TREE_CODE (newdecl) == FUNCTION_DECL && !new_is_definition)
13900     {
13901       if (DECL_BUILT_IN (olddecl))
13902         {
13903           DECL_BUILT_IN_CLASS (newdecl) = DECL_BUILT_IN_CLASS (olddecl);
13904           DECL_FUNCTION_CODE (newdecl) = DECL_FUNCTION_CODE (olddecl);
13905         }
13906       else
13907         DECL_FRAME_SIZE (newdecl) = DECL_FRAME_SIZE (olddecl);
13908
13909       DECL_RESULT (newdecl) = DECL_RESULT (olddecl);
13910       DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13911       DECL_SAVED_INSNS (newdecl) = DECL_SAVED_INSNS (olddecl);
13912       DECL_ARGUMENTS (newdecl) = DECL_ARGUMENTS (olddecl);
13913     }
13914
13915   /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13916      But preserve olddecl's DECL_UID.  */
13917   {
13918     register unsigned olddecl_uid = DECL_UID (olddecl);
13919
13920     memcpy ((char *) olddecl + sizeof (struct tree_common),
13921             (char *) newdecl + sizeof (struct tree_common),
13922             sizeof (struct tree_decl) - sizeof (struct tree_common));
13923     DECL_UID (olddecl) = olddecl_uid;
13924   }
13925
13926   return 1;
13927 }
13928
13929 /* Finish processing of a declaration;
13930    install its initial value.
13931    If the length of an array type is not known before,
13932    it must be determined now, from the initial value, or it is an error.  */
13933
13934 static void
13935 finish_decl (tree decl, tree init, bool is_top_level)
13936 {
13937   register tree type = TREE_TYPE (decl);
13938   int was_incomplete = (DECL_SIZE (decl) == 0);
13939   int temporary = allocation_temporary_p ();
13940   bool at_top_level = (current_binding_level == global_binding_level);
13941   bool top_level = is_top_level || at_top_level;
13942
13943   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13944      level anyway.  */
13945   assert (!is_top_level || !at_top_level);
13946
13947   if (TREE_CODE (decl) == PARM_DECL)
13948     assert (init == NULL_TREE);
13949   /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
13950      overlaps DECL_ARG_TYPE.  */
13951   else if (init == NULL_TREE)
13952     assert (DECL_INITIAL (decl) == NULL_TREE);
13953   else
13954     assert (DECL_INITIAL (decl) == error_mark_node);
13955
13956   if (init != NULL_TREE)
13957     {
13958       if (TREE_CODE (decl) != TYPE_DECL)
13959         DECL_INITIAL (decl) = init;
13960       else
13961         {
13962           /* typedef foo = bar; store the type of bar as the type of foo.  */
13963           TREE_TYPE (decl) = TREE_TYPE (init);
13964           DECL_INITIAL (decl) = init = 0;
13965         }
13966     }
13967
13968   /* Pop back to the obstack that is current for this binding level. This is
13969      because MAXINDEX, rtl, etc. to be made below must go in the permanent
13970      obstack.  But don't discard the temporary data yet.  */
13971   pop_obstacks ();
13972
13973   /* Deduce size of array from initialization, if not already known */
13974
13975   if (TREE_CODE (type) == ARRAY_TYPE
13976       && TYPE_DOMAIN (type) == 0
13977       && TREE_CODE (decl) != TYPE_DECL)
13978     {
13979       assert (top_level);
13980       assert (was_incomplete);
13981
13982       layout_decl (decl, 0);
13983     }
13984
13985   if (TREE_CODE (decl) == VAR_DECL)
13986     {
13987       if (DECL_SIZE (decl) == NULL_TREE
13988           && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
13989         layout_decl (decl, 0);
13990
13991       if (DECL_SIZE (decl) == NULL_TREE
13992           && (TREE_STATIC (decl)
13993               ?
13994       /* A static variable with an incomplete type is an error if it is
13995          initialized. Also if it is not file scope. Otherwise, let it
13996          through, but if it is not `extern' then it may cause an error
13997          message later.  */
13998               (DECL_INITIAL (decl) != 0 || DECL_CONTEXT (decl) != 0)
13999               :
14000       /* An automatic variable with an incomplete type is an error.  */
14001               !DECL_EXTERNAL (decl)))
14002         {
14003           assert ("storage size not known" == NULL);
14004           abort ();
14005         }
14006
14007       if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
14008           && (DECL_SIZE (decl) != 0)
14009           && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
14010         {
14011           assert ("storage size not constant" == NULL);
14012           abort ();
14013         }
14014     }
14015
14016   /* Output the assembler code and/or RTL code for variables and functions,
14017      unless the type is an undefined structure or union. If not, it will get
14018      done when the type is completed.  */
14019
14020   if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL)
14021     {
14022       rest_of_decl_compilation (decl, NULL,
14023                                 DECL_CONTEXT (decl) == 0,
14024                                 0);
14025
14026       if (DECL_CONTEXT (decl) != 0)
14027         {
14028           /* Recompute the RTL of a local array now if it used to be an
14029              incomplete type.  */
14030           if (was_incomplete
14031               && !TREE_STATIC (decl) && !DECL_EXTERNAL (decl))
14032             {
14033               /* If we used it already as memory, it must stay in memory.  */
14034               TREE_ADDRESSABLE (decl) = TREE_USED (decl);
14035               /* If it's still incomplete now, no init will save it.  */
14036               if (DECL_SIZE (decl) == 0)
14037                 DECL_INITIAL (decl) = 0;
14038               expand_decl (decl);
14039             }
14040           /* Compute and store the initial value.  */
14041           if (TREE_CODE (decl) != FUNCTION_DECL)
14042             expand_decl_init (decl);
14043         }
14044     }
14045   else if (TREE_CODE (decl) == TYPE_DECL)
14046     {
14047       rest_of_decl_compilation (decl, NULL_PTR,
14048                                 DECL_CONTEXT (decl) == 0,
14049                                 0);
14050     }
14051
14052   if (!(TREE_CODE (decl) == FUNCTION_DECL && DECL_INLINE (decl))
14053       && temporary
14054   /* DECL_INITIAL is not defined in PARM_DECLs, since it shares space with
14055      DECL_ARG_TYPE.  */
14056       && TREE_CODE (decl) != PARM_DECL)
14057     {
14058       /* We need to remember that this array HAD an initialization, but
14059          discard the actual temporary nodes, since we can't have a permanent
14060          node keep pointing to them.  */
14061       /* We make an exception for inline functions, since it's normal for a
14062          local extern redeclaration of an inline function to have a copy of
14063          the top-level decl's DECL_INLINE.  */
14064       if ((DECL_INITIAL (decl) != 0)
14065           && (DECL_INITIAL (decl) != error_mark_node))
14066         {
14067           /* If this is a const variable, then preserve the
14068              initializer instead of discarding it so that we can optimize
14069              references to it.  */
14070           /* This test used to include TREE_STATIC, but this won't be set
14071              for function level initializers.  */
14072           if (TREE_READONLY (decl))
14073             {
14074               preserve_initializer ();
14075
14076               /* The initializer and DECL must have the same (or equivalent
14077                  types), but if the initializer is a STRING_CST, its type
14078                  might not be on the right obstack, so copy the type
14079                  of DECL.  */
14080               TREE_TYPE (DECL_INITIAL (decl)) = type;
14081             }
14082           else
14083             DECL_INITIAL (decl) = error_mark_node;
14084         }
14085     }
14086
14087   /* If we have gone back from temporary to permanent allocation, actually
14088      free the temporary space that we no longer need.  */
14089   if (temporary && !allocation_temporary_p ())
14090     permanent_allocation (0);
14091
14092   /* At the end of a declaration, throw away any variable type sizes of types
14093      defined inside that declaration.  There is no use computing them in the
14094      following function definition.  */
14095   if (current_binding_level == global_binding_level)
14096     get_pending_sizes ();
14097 }
14098
14099 /* Finish up a function declaration and compile that function
14100    all the way to assembler language output.  The free the storage
14101    for the function definition.
14102
14103    This is called after parsing the body of the function definition.
14104
14105    NESTED is nonzero if the function being finished is nested in another.  */
14106
14107 static void
14108 finish_function (int nested)
14109 {
14110   register tree fndecl = current_function_decl;
14111
14112   assert (fndecl != NULL_TREE);
14113   if (TREE_CODE (fndecl) != ERROR_MARK)
14114     {
14115       if (nested)
14116         assert (DECL_CONTEXT (fndecl) != NULL_TREE);
14117       else
14118         assert (DECL_CONTEXT (fndecl) == NULL_TREE);
14119     }
14120
14121 /*  TREE_READONLY (fndecl) = 1;
14122     This caused &foo to be of type ptr-to-const-function
14123     which then got a warning when stored in a ptr-to-function variable.  */
14124
14125   poplevel (1, 0, 1);
14126
14127   if (TREE_CODE (fndecl) != ERROR_MARK)
14128     {
14129       BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
14130
14131       /* Must mark the RESULT_DECL as being in this function.  */
14132
14133       DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
14134
14135       /* Obey `register' declarations if `setjmp' is called in this fn.  */
14136       /* Generate rtl for function exit.  */
14137       expand_function_end (input_filename, lineno, 0);
14138
14139       /* So we can tell if jump_optimize sets it to 1.  */
14140       can_reach_end = 0;
14141
14142       /* If this is a nested function, protect the local variables in the stack
14143          above us from being collected while we're compiling this function.  */
14144       if (ggc_p && nested)
14145         ggc_push_context ();
14146
14147       /* Run the optimizers and output the assembler code for this function.  */
14148       rest_of_compilation (fndecl);
14149
14150       /* Undo the GC context switch.  */
14151       if (ggc_p && nested)
14152         ggc_pop_context ();
14153     }
14154
14155   /* Free all the tree nodes making up this function.  */
14156   /* Switch back to allocating nodes permanently until we start another
14157      function.  */
14158   if (!nested)
14159     permanent_allocation (1);
14160
14161   if (TREE_CODE (fndecl) != ERROR_MARK
14162       && !nested
14163       && DECL_SAVED_INSNS (fndecl) == 0)
14164     {
14165       /* Stop pointing to the local nodes about to be freed.  */
14166       /* But DECL_INITIAL must remain nonzero so we know this was an actual
14167          function definition.  */
14168       /* For a nested function, this is done in pop_f_function_context.  */
14169       /* If rest_of_compilation set this to 0, leave it 0.  */
14170       if (DECL_INITIAL (fndecl) != 0)
14171         DECL_INITIAL (fndecl) = error_mark_node;
14172       DECL_ARGUMENTS (fndecl) = 0;
14173     }
14174
14175   if (!nested)
14176     {
14177       /* Let the error reporting routines know that we're outside a function.
14178          For a nested function, this value is used in pop_c_function_context
14179          and then reset via pop_function_context.  */
14180       ffecom_outer_function_decl_ = current_function_decl = NULL;
14181     }
14182 }
14183
14184 /* Plug-in replacement for identifying the name of a decl and, for a
14185    function, what we call it in diagnostics.  For now, "program unit"
14186    should suffice, since it's a bit of a hassle to figure out which
14187    of several kinds of things it is.  Note that it could conceivably
14188    be a statement function, which probably isn't really a program unit
14189    per se, but if that comes up, it should be easy to check (being a
14190    nested function and all).  */
14191
14192 static const char *
14193 lang_printable_name (tree decl, int v)
14194 {
14195   /* Just to keep GCC quiet about the unused variable.
14196      In theory, differing values of V should produce different
14197      output.  */
14198   switch (v)
14199     {
14200     default:
14201       if (TREE_CODE (decl) == ERROR_MARK)
14202         return "erroneous code";
14203       return IDENTIFIER_POINTER (DECL_NAME (decl));
14204     }
14205 }
14206
14207 /* g77's function to print out name of current function that caused
14208    an error.  */
14209
14210 #if BUILT_FOR_270
14211 static void
14212 lang_print_error_function (const char *file)
14213 {
14214   static ffeglobal last_g = NULL;
14215   static ffesymbol last_s = NULL;
14216   ffeglobal g;
14217   ffesymbol s;
14218   const char *kind;
14219
14220   if ((ffecom_primary_entry_ == NULL)
14221       || (ffesymbol_global (ffecom_primary_entry_) == NULL))
14222     {
14223       g = NULL;
14224       s = NULL;
14225       kind = NULL;
14226     }
14227   else
14228     {
14229       g = ffesymbol_global (ffecom_primary_entry_);
14230       if (ffecom_nested_entry_ == NULL)
14231         {
14232           s = ffecom_primary_entry_;
14233           switch (ffesymbol_kind (s))
14234             {
14235             case FFEINFO_kindFUNCTION:
14236               kind = "function";
14237               break;
14238
14239             case FFEINFO_kindSUBROUTINE:
14240               kind = "subroutine";
14241               break;
14242
14243             case FFEINFO_kindPROGRAM:
14244               kind = "program";
14245               break;
14246
14247             case FFEINFO_kindBLOCKDATA:
14248               kind = "block-data";
14249               break;
14250
14251             default:
14252               kind = ffeinfo_kind_message (ffesymbol_kind (s));
14253               break;
14254             }
14255         }
14256       else
14257         {
14258           s = ffecom_nested_entry_;
14259           kind = "statement function";
14260         }
14261     }
14262
14263   if ((last_g != g) || (last_s != s))
14264     {
14265       if (file)
14266         fprintf (stderr, "%s: ", file);
14267
14268       if (s == NULL)
14269         fprintf (stderr, "Outside of any program unit:\n");
14270       else
14271         {
14272           const char *name = ffesymbol_text (s);
14273
14274           fprintf (stderr, "In %s `%s':\n", kind, name);
14275         }
14276
14277       last_g = g;
14278       last_s = s;
14279     }
14280 }
14281 #endif
14282
14283 /* Similar to `lookup_name' but look only at current binding level.  */
14284
14285 static tree
14286 lookup_name_current_level (tree name)
14287 {
14288   register tree t;
14289
14290   if (current_binding_level == global_binding_level)
14291     return IDENTIFIER_GLOBAL_VALUE (name);
14292
14293   if (IDENTIFIER_LOCAL_VALUE (name) == 0)
14294     return 0;
14295
14296   for (t = current_binding_level->names; t; t = TREE_CHAIN (t))
14297     if (DECL_NAME (t) == name)
14298       break;
14299
14300   return t;
14301 }
14302
14303 /* Create a new `struct binding_level'.  */
14304
14305 static struct binding_level *
14306 make_binding_level ()
14307 {
14308   /* NOSTRICT */
14309   return (struct binding_level *) xmalloc (sizeof (struct binding_level));
14310 }
14311
14312 /* Save and restore the variables in this file and elsewhere
14313    that keep track of the progress of compilation of the current function.
14314    Used for nested functions.  */
14315
14316 struct f_function
14317 {
14318   struct f_function *next;
14319   tree named_labels;
14320   tree shadowed_labels;
14321   struct binding_level *binding_level;
14322 };
14323
14324 struct f_function *f_function_chain;
14325
14326 /* Restore the variables used during compilation of a C function.  */
14327
14328 static void
14329 pop_f_function_context ()
14330 {
14331   struct f_function *p = f_function_chain;
14332   tree link;
14333
14334   /* Bring back all the labels that were shadowed.  */
14335   for (link = shadowed_labels; link; link = TREE_CHAIN (link))
14336     if (DECL_NAME (TREE_VALUE (link)) != 0)
14337       IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link)))
14338         = TREE_VALUE (link);
14339
14340   if (current_function_decl != error_mark_node
14341       && DECL_SAVED_INSNS (current_function_decl) == 0)
14342     {
14343       /* Stop pointing to the local nodes about to be freed.  */
14344       /* But DECL_INITIAL must remain nonzero so we know this was an actual
14345          function definition.  */
14346       DECL_INITIAL (current_function_decl) = error_mark_node;
14347       DECL_ARGUMENTS (current_function_decl) = 0;
14348     }
14349
14350   pop_function_context ();
14351
14352   f_function_chain = p->next;
14353
14354   named_labels = p->named_labels;
14355   shadowed_labels = p->shadowed_labels;
14356   current_binding_level = p->binding_level;
14357
14358   free (p);
14359 }
14360
14361 /* Save and reinitialize the variables
14362    used during compilation of a C function.  */
14363
14364 static void
14365 push_f_function_context ()
14366 {
14367   struct f_function *p
14368   = (struct f_function *) xmalloc (sizeof (struct f_function));
14369
14370   push_function_context ();
14371
14372   p->next = f_function_chain;
14373   f_function_chain = p;
14374
14375   p->named_labels = named_labels;
14376   p->shadowed_labels = shadowed_labels;
14377   p->binding_level = current_binding_level;
14378 }
14379
14380 static void
14381 push_parm_decl (tree parm)
14382 {
14383   int old_immediate_size_expand = immediate_size_expand;
14384
14385   /* Don't try computing parm sizes now -- wait till fn is called.  */
14386
14387   immediate_size_expand = 0;
14388
14389   push_obstacks_nochange ();
14390
14391   /* Fill in arg stuff.  */
14392
14393   DECL_ARG_TYPE (parm) = TREE_TYPE (parm);
14394   DECL_ARG_TYPE_AS_WRITTEN (parm) = TREE_TYPE (parm);
14395   TREE_READONLY (parm) = 1;     /* All implementation args are read-only. */
14396
14397   parm = pushdecl (parm);
14398
14399   immediate_size_expand = old_immediate_size_expand;
14400
14401   finish_decl (parm, NULL_TREE, FALSE);
14402 }
14403
14404 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate.  */
14405
14406 static tree
14407 pushdecl_top_level (x)
14408      tree x;
14409 {
14410   register tree t;
14411   register struct binding_level *b = current_binding_level;
14412   register tree f = current_function_decl;
14413
14414   current_binding_level = global_binding_level;
14415   current_function_decl = NULL_TREE;
14416   t = pushdecl (x);
14417   current_binding_level = b;
14418   current_function_decl = f;
14419   return t;
14420 }
14421
14422 /* Store the list of declarations of the current level.
14423    This is done for the parameter declarations of a function being defined,
14424    after they are modified in the light of any missing parameters.  */
14425
14426 static tree
14427 storedecls (decls)
14428      tree decls;
14429 {
14430   return current_binding_level->names = decls;
14431 }
14432
14433 /* Store the parameter declarations into the current function declaration.
14434    This is called after parsing the parameter declarations, before
14435    digesting the body of the function.
14436
14437    For an old-style definition, modify the function's type
14438    to specify at least the number of arguments.  */
14439
14440 static void
14441 store_parm_decls (int is_main_program UNUSED)
14442 {
14443   register tree fndecl = current_function_decl;
14444
14445   if (fndecl == error_mark_node)
14446     return;
14447
14448   /* This is a chain of PARM_DECLs from old-style parm declarations.  */
14449   DECL_ARGUMENTS (fndecl) = storedecls (nreverse (getdecls ()));
14450
14451   /* Initialize the RTL code for the function.  */
14452
14453   init_function_start (fndecl, input_filename, lineno);
14454
14455   /* Set up parameters and prepare for return, for the function.  */
14456
14457   expand_function_start (fndecl, 0);
14458 }
14459
14460 static tree
14461 start_decl (tree decl, bool is_top_level)
14462 {
14463   register tree tem;
14464   bool at_top_level = (current_binding_level == global_binding_level);
14465   bool top_level = is_top_level || at_top_level;
14466
14467   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
14468      level anyway.  */
14469   assert (!is_top_level || !at_top_level);
14470
14471   /* The corresponding pop_obstacks is in finish_decl.  */
14472   push_obstacks_nochange ();
14473
14474   if (DECL_INITIAL (decl) != NULL_TREE)
14475     {
14476       assert (DECL_INITIAL (decl) == error_mark_node);
14477       assert (!DECL_EXTERNAL (decl));
14478     }
14479   else if (top_level)
14480     assert ((TREE_STATIC (decl) == 1) || DECL_EXTERNAL (decl) == 1);
14481
14482   /* For Fortran, we by default put things in .common when possible.  */
14483   DECL_COMMON (decl) = 1;
14484
14485   /* Add this decl to the current binding level. TEM may equal DECL or it may
14486      be a previous decl of the same name.  */
14487   if (is_top_level)
14488     tem = pushdecl_top_level (decl);
14489   else
14490     tem = pushdecl (decl);
14491
14492   /* For a local variable, define the RTL now.  */
14493   if (!top_level
14494   /* But not if this is a duplicate decl and we preserved the rtl from the
14495      previous one (which may or may not happen).  */
14496       && DECL_RTL (tem) == 0)
14497     {
14498       if (TYPE_SIZE (TREE_TYPE (tem)) != 0)
14499         expand_decl (tem);
14500       else if (TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE
14501                && DECL_INITIAL (tem) != 0)
14502         expand_decl (tem);
14503     }
14504
14505   if (DECL_INITIAL (tem) != NULL_TREE)
14506     {
14507       /* When parsing and digesting the initializer, use temporary storage.
14508          Do this even if we will ignore the value.  */
14509       if (at_top_level)
14510         temporary_allocation ();
14511     }
14512
14513   return tem;
14514 }
14515
14516 /* Create the FUNCTION_DECL for a function definition.
14517    DECLSPECS and DECLARATOR are the parts of the declaration;
14518    they describe the function's name and the type it returns,
14519    but twisted together in a fashion that parallels the syntax of C.
14520
14521    This function creates a binding context for the function body
14522    as well as setting up the FUNCTION_DECL in current_function_decl.
14523
14524    Returns 1 on success.  If the DECLARATOR is not suitable for a function
14525    (it defines a datum instead), we return 0, which tells
14526    yyparse to report a parse error.
14527
14528    NESTED is nonzero for a function nested within another function.  */
14529
14530 static void
14531 start_function (tree name, tree type, int nested, int public)
14532 {
14533   tree decl1;
14534   tree restype;
14535   int old_immediate_size_expand = immediate_size_expand;
14536
14537   named_labels = 0;
14538   shadowed_labels = 0;
14539
14540   /* Don't expand any sizes in the return type of the function.  */
14541   immediate_size_expand = 0;
14542
14543   if (nested)
14544     {
14545       assert (!public);
14546       assert (current_function_decl != NULL_TREE);
14547       assert (DECL_CONTEXT (current_function_decl) == NULL_TREE);
14548     }
14549   else
14550     {
14551       assert (current_function_decl == NULL_TREE);
14552     }
14553
14554   if (TREE_CODE (type) == ERROR_MARK)
14555     decl1 = current_function_decl = error_mark_node;
14556   else
14557     {
14558       decl1 = build_decl (FUNCTION_DECL,
14559                           name,
14560                           type);
14561       TREE_PUBLIC (decl1) = public ? 1 : 0;
14562       if (nested)
14563         DECL_INLINE (decl1) = 1;
14564       TREE_STATIC (decl1) = 1;
14565       DECL_EXTERNAL (decl1) = 0;
14566
14567       announce_function (decl1);
14568
14569       /* Make the init_value nonzero so pushdecl knows this is not tentative.
14570          error_mark_node is replaced below (in poplevel) with the BLOCK.  */
14571       DECL_INITIAL (decl1) = error_mark_node;
14572
14573       /* Record the decl so that the function name is defined. If we already have
14574          a decl for this name, and it is a FUNCTION_DECL, use the old decl.  */
14575
14576       current_function_decl = pushdecl (decl1);
14577     }
14578
14579   if (!nested)
14580     ffecom_outer_function_decl_ = current_function_decl;
14581
14582   pushlevel (0);
14583   current_binding_level->prep_state = 2;
14584
14585   if (TREE_CODE (current_function_decl) != ERROR_MARK)
14586     {
14587       make_function_rtl (current_function_decl);
14588
14589       restype = TREE_TYPE (TREE_TYPE (current_function_decl));
14590       DECL_RESULT (current_function_decl)
14591         = build_decl (RESULT_DECL, NULL_TREE, restype);
14592     }
14593
14594   if (!nested)
14595     /* Allocate further tree nodes temporarily during compilation of this
14596        function only.  */
14597     temporary_allocation ();
14598
14599   if (!nested && (TREE_CODE (current_function_decl) != ERROR_MARK))
14600     TREE_ADDRESSABLE (current_function_decl) = 1;
14601
14602   immediate_size_expand = old_immediate_size_expand;
14603 }
14604 \f
14605 /* Here are the public functions the GNU back end needs.  */
14606
14607 tree
14608 convert (type, expr)
14609      tree type, expr;
14610 {
14611   register tree e = expr;
14612   register enum tree_code code = TREE_CODE (type);
14613
14614   if (type == TREE_TYPE (e)
14615       || TREE_CODE (e) == ERROR_MARK)
14616     return e;
14617   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
14618     return fold (build1 (NOP_EXPR, type, e));
14619   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
14620       || code == ERROR_MARK)
14621     return error_mark_node;
14622   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
14623     {
14624       assert ("void value not ignored as it ought to be" == NULL);
14625       return error_mark_node;
14626     }
14627   if (code == VOID_TYPE)
14628     return build1 (CONVERT_EXPR, type, e);
14629   if ((code != RECORD_TYPE)
14630       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
14631     e = ffecom_1 (REALPART_EXPR, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))),
14632                   e);
14633   if (code == INTEGER_TYPE || code == ENUMERAL_TYPE)
14634     return fold (convert_to_integer (type, e));
14635   if (code == POINTER_TYPE)
14636     return fold (convert_to_pointer (type, e));
14637   if (code == REAL_TYPE)
14638     return fold (convert_to_real (type, e));
14639   if (code == COMPLEX_TYPE)
14640     return fold (convert_to_complex (type, e));
14641   if (code == RECORD_TYPE)
14642     return fold (ffecom_convert_to_complex_ (type, e));
14643
14644   assert ("conversion to non-scalar type requested" == NULL);
14645   return error_mark_node;
14646 }
14647
14648 /* integrate_decl_tree calls this function, but since we don't use the
14649    DECL_LANG_SPECIFIC field, this is a no-op.  */
14650
14651 void
14652 copy_lang_decl (node)
14653      tree node UNUSED;
14654 {
14655 }
14656
14657 /* Return the list of declarations of the current level.
14658    Note that this list is in reverse order unless/until
14659    you nreverse it; and when you do nreverse it, you must
14660    store the result back using `storedecls' or you will lose.  */
14661
14662 tree
14663 getdecls ()
14664 {
14665   return current_binding_level->names;
14666 }
14667
14668 /* Nonzero if we are currently in the global binding level.  */
14669
14670 int
14671 global_bindings_p ()
14672 {
14673   return current_binding_level == global_binding_level;
14674 }
14675
14676 /* Print an error message for invalid use of an incomplete type.
14677    VALUE is the expression that was used (or 0 if that isn't known)
14678    and TYPE is the type that was invalid.  */
14679
14680 void
14681 incomplete_type_error (value, type)
14682      tree value UNUSED;
14683      tree type;
14684 {
14685   if (TREE_CODE (type) == ERROR_MARK)
14686     return;
14687
14688   assert ("incomplete type?!?" == NULL);
14689 }
14690
14691 /* Mark ARG for GC.  */
14692 static void
14693 mark_binding_level (void *arg)
14694 {
14695   struct binding_level *level = *(struct binding_level **) arg;
14696
14697   while (level)
14698     {
14699       ggc_mark_tree (level->names);
14700       ggc_mark_tree (level->blocks);
14701       ggc_mark_tree (level->this_block);
14702       level = level->level_chain;
14703     }
14704 }
14705
14706 void
14707 init_decl_processing ()
14708 {
14709   static tree *const tree_roots[] = {
14710     &current_function_decl,
14711     &string_type_node,
14712     &ffecom_tree_fun_type_void,
14713     &ffecom_integer_zero_node,
14714     &ffecom_integer_one_node,
14715     &ffecom_tree_subr_type,
14716     &ffecom_tree_ptr_to_subr_type,
14717     &ffecom_tree_blockdata_type,
14718     &ffecom_tree_xargc_,
14719     &ffecom_f2c_integer_type_node,
14720     &ffecom_f2c_ptr_to_integer_type_node,
14721     &ffecom_f2c_address_type_node,
14722     &ffecom_f2c_real_type_node,
14723     &ffecom_f2c_ptr_to_real_type_node,
14724     &ffecom_f2c_doublereal_type_node,
14725     &ffecom_f2c_complex_type_node,
14726     &ffecom_f2c_doublecomplex_type_node,
14727     &ffecom_f2c_longint_type_node,
14728     &ffecom_f2c_logical_type_node,
14729     &ffecom_f2c_flag_type_node,
14730     &ffecom_f2c_ftnlen_type_node,
14731     &ffecom_f2c_ftnlen_zero_node,
14732     &ffecom_f2c_ftnlen_one_node,
14733     &ffecom_f2c_ftnlen_two_node,
14734     &ffecom_f2c_ptr_to_ftnlen_type_node,
14735     &ffecom_f2c_ftnint_type_node,
14736     &ffecom_f2c_ptr_to_ftnint_type_node,
14737     &ffecom_outer_function_decl_,
14738     &ffecom_previous_function_decl_,
14739     &ffecom_which_entrypoint_decl_,
14740     &ffecom_float_zero_,
14741     &ffecom_float_half_,
14742     &ffecom_double_zero_,
14743     &ffecom_double_half_,
14744     &ffecom_func_result_,
14745     &ffecom_func_length_,
14746     &ffecom_multi_type_node_,
14747     &ffecom_multi_retval_,
14748     &named_labels,
14749     &shadowed_labels
14750   };
14751   size_t i;
14752
14753   malloc_init ();
14754
14755   /* Record our roots.  */
14756   for (i = 0; i < sizeof(tree_roots)/sizeof(tree_roots[0]); i++)
14757     ggc_add_tree_root (tree_roots[i], 1);
14758   ggc_add_tree_root (&ffecom_tree_type[0][0],
14759                      FFEINFO_basictype*FFEINFO_kindtype);
14760   ggc_add_tree_root (&ffecom_tree_fun_type[0][0],
14761                      FFEINFO_basictype*FFEINFO_kindtype);
14762   ggc_add_tree_root (&ffecom_tree_ptr_to_fun_type[0][0],
14763                      FFEINFO_basictype*FFEINFO_kindtype);
14764   ggc_add_tree_root (ffecom_gfrt_, FFECOM_gfrt);
14765   ggc_add_root (&current_binding_level, 1, sizeof current_binding_level,
14766                 mark_binding_level);
14767   ggc_add_root (&free_binding_level, 1, sizeof current_binding_level,
14768                 mark_binding_level);
14769   ggc_add_root (&tracker_head, 1, sizeof tracker_head, mark_tracker_head);
14770
14771   ffe_init_0 ();
14772 }
14773
14774 char *
14775 init_parse (filename)
14776      char *filename;
14777 {
14778   /* Open input file.  */
14779   if (filename == 0 || !strcmp (filename, "-"))
14780     {
14781       finput = stdin;
14782       filename = "stdin";
14783     }
14784   else
14785     finput = fopen (filename, "r");
14786   if (finput == 0)
14787     pfatal_with_name (filename);
14788
14789 #ifdef IO_BUFFER_SIZE
14790   setvbuf (finput, (char *) xmalloc (IO_BUFFER_SIZE), _IOFBF, IO_BUFFER_SIZE);
14791 #endif
14792
14793   /* Make identifier nodes long enough for the language-specific slots.  */
14794   set_identifier_size (sizeof (struct lang_identifier));
14795   decl_printable_name = lang_printable_name;
14796 #if BUILT_FOR_270
14797   print_error_function = lang_print_error_function;
14798 #endif
14799
14800   return filename;
14801 }
14802
14803 void
14804 finish_parse ()
14805 {
14806   fclose (finput);
14807 }
14808
14809 /* Delete the node BLOCK from the current binding level.
14810    This is used for the block inside a stmt expr ({...})
14811    so that the block can be reinserted where appropriate.  */
14812
14813 static void
14814 delete_block (block)
14815      tree block;
14816 {
14817   tree t;
14818   if (current_binding_level->blocks == block)
14819     current_binding_level->blocks = TREE_CHAIN (block);
14820   for (t = current_binding_level->blocks; t;)
14821     {
14822       if (TREE_CHAIN (t) == block)
14823         TREE_CHAIN (t) = TREE_CHAIN (block);
14824       else
14825         t = TREE_CHAIN (t);
14826     }
14827   TREE_CHAIN (block) = NULL;
14828   /* Clear TREE_USED which is always set by poplevel.
14829      The flag is set again if insert_block is called.  */
14830   TREE_USED (block) = 0;
14831 }
14832
14833 void
14834 insert_block (block)
14835      tree block;
14836 {
14837   TREE_USED (block) = 1;
14838   current_binding_level->blocks
14839     = chainon (current_binding_level->blocks, block);
14840 }
14841
14842 int
14843 lang_decode_option (argc, argv)
14844      int argc;
14845      char **argv;
14846 {
14847   return ffe_decode_option (argc, argv);
14848 }
14849
14850 /* used by print-tree.c */
14851
14852 void
14853 lang_print_xnode (file, node, indent)
14854      FILE *file UNUSED;
14855      tree node UNUSED;
14856      int indent UNUSED;
14857 {
14858 }
14859
14860 void
14861 lang_finish ()
14862 {
14863   ffe_terminate_0 ();
14864
14865   if (ffe_is_ffedebug ())
14866     malloc_pool_display (malloc_pool_image ());
14867 }
14868
14869 const char *
14870 lang_identify ()
14871 {
14872   return "f77";
14873 }
14874
14875 void
14876 lang_init_options ()
14877 {
14878   /* Set default options for Fortran.  */
14879   flag_move_all_movables = 1;
14880   flag_reduce_all_givs = 1;
14881   flag_argument_noalias = 2;
14882   flag_errno_math = 0;
14883   flag_complex_divide_method = 1;
14884 }
14885
14886 void
14887 lang_init ()
14888 {
14889   /* If the file is output from cpp, it should contain a first line
14890      `# 1 "real-filename"', and the current design of gcc (toplev.c
14891      in particular and the way it sets up information relied on by
14892      INCLUDE) requires that we read this now, and store the
14893      "real-filename" info in master_input_filename.  Ask the lexer
14894      to try doing this.  */
14895   ffelex_hash_kludge (finput);
14896 }
14897
14898 int
14899 mark_addressable (exp)
14900      tree exp;
14901 {
14902   register tree x = exp;
14903   while (1)
14904     switch (TREE_CODE (x))
14905       {
14906       case ADDR_EXPR:
14907       case COMPONENT_REF:
14908       case ARRAY_REF:
14909         x = TREE_OPERAND (x, 0);
14910         break;
14911
14912       case CONSTRUCTOR:
14913         TREE_ADDRESSABLE (x) = 1;
14914         return 1;
14915
14916       case VAR_DECL:
14917       case CONST_DECL:
14918       case PARM_DECL:
14919       case RESULT_DECL:
14920         if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)
14921             && DECL_NONLOCAL (x))
14922           {
14923             if (TREE_PUBLIC (x))
14924               {
14925                 assert ("address of global register var requested" == NULL);
14926                 return 0;
14927               }
14928             assert ("address of register variable requested" == NULL);
14929           }
14930         else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
14931           {
14932             if (TREE_PUBLIC (x))
14933               {
14934                 assert ("address of global register var requested" == NULL);
14935                 return 0;
14936               }
14937             assert ("address of register var requested" == NULL);
14938           }
14939         put_var_into_stack (x);
14940
14941         /* drops in */
14942       case FUNCTION_DECL:
14943         TREE_ADDRESSABLE (x) = 1;
14944 #if 0                           /* poplevel deals with this now.  */
14945         if (DECL_CONTEXT (x) == 0)
14946           TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1;
14947 #endif
14948
14949       default:
14950         return 1;
14951       }
14952 }
14953
14954 /* If DECL has a cleanup, build and return that cleanup here.
14955    This is a callback called by expand_expr.  */
14956
14957 tree
14958 maybe_build_cleanup (decl)
14959      tree decl UNUSED;
14960 {
14961   /* There are no cleanups in Fortran.  */
14962   return NULL_TREE;
14963 }
14964
14965 /* Exit a binding level.
14966    Pop the level off, and restore the state of the identifier-decl mappings
14967    that were in effect when this level was entered.
14968
14969    If KEEP is nonzero, this level had explicit declarations, so
14970    and create a "block" (a BLOCK node) for the level
14971    to record its declarations and subblocks for symbol table output.
14972
14973    If FUNCTIONBODY is nonzero, this level is the body of a function,
14974    so create a block as if KEEP were set and also clear out all
14975    label names.
14976
14977    If REVERSE is nonzero, reverse the order of decls before putting
14978    them into the BLOCK.  */
14979
14980 tree
14981 poplevel (keep, reverse, functionbody)
14982      int keep;
14983      int reverse;
14984      int functionbody;
14985 {
14986   register tree link;
14987   /* The chain of decls was accumulated in reverse order.
14988      Put it into forward order, just for cleanliness.  */
14989   tree decls;
14990   tree subblocks = current_binding_level->blocks;
14991   tree block = 0;
14992   tree decl;
14993   int block_previously_created;
14994
14995   /* Get the decls in the order they were written.
14996      Usually current_binding_level->names is in reverse order.
14997      But parameter decls were previously put in forward order.  */
14998
14999   if (reverse)
15000     current_binding_level->names
15001       = decls = nreverse (current_binding_level->names);
15002   else
15003     decls = current_binding_level->names;
15004
15005   /* Output any nested inline functions within this block
15006      if they weren't already output.  */
15007
15008   for (decl = decls; decl; decl = TREE_CHAIN (decl))
15009     if (TREE_CODE (decl) == FUNCTION_DECL
15010         && ! TREE_ASM_WRITTEN (decl)
15011         && DECL_INITIAL (decl) != 0
15012         && TREE_ADDRESSABLE (decl))
15013       {
15014         /* If this decl was copied from a file-scope decl
15015            on account of a block-scope extern decl,
15016            propagate TREE_ADDRESSABLE to the file-scope decl.
15017
15018            DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
15019            true, since then the decl goes through save_for_inline_copying.  */
15020         if (DECL_ABSTRACT_ORIGIN (decl) != 0
15021             && DECL_ABSTRACT_ORIGIN (decl) != decl)
15022           TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1;
15023         else if (DECL_SAVED_INSNS (decl) != 0)
15024           {
15025             push_function_context ();
15026             output_inline_function (decl);
15027             pop_function_context ();
15028           }
15029       }
15030
15031   /* If there were any declarations or structure tags in that level,
15032      or if this level is a function body,
15033      create a BLOCK to record them for the life of this function.  */
15034
15035   block = 0;
15036   block_previously_created = (current_binding_level->this_block != 0);
15037   if (block_previously_created)
15038     block = current_binding_level->this_block;
15039   else if (keep || functionbody)
15040     block = make_node (BLOCK);
15041   if (block != 0)
15042     {
15043       BLOCK_VARS (block) = decls;
15044       BLOCK_SUBBLOCKS (block) = subblocks;
15045     }
15046
15047   /* In each subblock, record that this is its superior.  */
15048
15049   for (link = subblocks; link; link = TREE_CHAIN (link))
15050     BLOCK_SUPERCONTEXT (link) = block;
15051
15052   /* Clear out the meanings of the local variables of this level.  */
15053
15054   for (link = decls; link; link = TREE_CHAIN (link))
15055     {
15056       if (DECL_NAME (link) != 0)
15057         {
15058           /* If the ident. was used or addressed via a local extern decl,
15059              don't forget that fact.  */
15060           if (DECL_EXTERNAL (link))
15061             {
15062               if (TREE_USED (link))
15063                 TREE_USED (DECL_NAME (link)) = 1;
15064               if (TREE_ADDRESSABLE (link))
15065                 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link)) = 1;
15066             }
15067           IDENTIFIER_LOCAL_VALUE (DECL_NAME (link)) = 0;
15068         }
15069     }
15070
15071   /* If the level being exited is the top level of a function,
15072      check over all the labels, and clear out the current
15073      (function local) meanings of their names.  */
15074
15075   if (functionbody)
15076     {
15077       /* If this is the top level block of a function,
15078          the vars are the function's parameters.
15079          Don't leave them in the BLOCK because they are
15080          found in the FUNCTION_DECL instead.  */
15081
15082       BLOCK_VARS (block) = 0;
15083     }
15084
15085   /* Pop the current level, and free the structure for reuse.  */
15086
15087   {
15088     register struct binding_level *level = current_binding_level;
15089     current_binding_level = current_binding_level->level_chain;
15090
15091     level->level_chain = free_binding_level;
15092     free_binding_level = level;
15093   }
15094
15095   /* Dispose of the block that we just made inside some higher level.  */
15096   if (functionbody
15097       && current_function_decl != error_mark_node)
15098     DECL_INITIAL (current_function_decl) = block;
15099   else if (block)
15100     {
15101       if (!block_previously_created)
15102         current_binding_level->blocks
15103           = chainon (current_binding_level->blocks, block);
15104     }
15105   /* If we did not make a block for the level just exited,
15106      any blocks made for inner levels
15107      (since they cannot be recorded as subblocks in that level)
15108      must be carried forward so they will later become subblocks
15109      of something else.  */
15110   else if (subblocks)
15111     current_binding_level->blocks
15112       = chainon (current_binding_level->blocks, subblocks);
15113
15114   if (block)
15115     TREE_USED (block) = 1;
15116   return block;
15117 }
15118
15119 void
15120 print_lang_decl (file, node, indent)
15121      FILE *file UNUSED;
15122      tree node UNUSED;
15123      int indent UNUSED;
15124 {
15125 }
15126
15127 void
15128 print_lang_identifier (file, node, indent)
15129      FILE *file;
15130      tree node;
15131      int indent;
15132 {
15133   print_node (file, "global", IDENTIFIER_GLOBAL_VALUE (node), indent + 4);
15134   print_node (file, "local", IDENTIFIER_LOCAL_VALUE (node), indent + 4);
15135 }
15136
15137 void
15138 print_lang_statistics ()
15139 {
15140 }
15141
15142 void
15143 print_lang_type (file, node, indent)
15144      FILE *file UNUSED;
15145      tree node UNUSED;
15146      int indent UNUSED;
15147 {
15148 }
15149
15150 /* Record a decl-node X as belonging to the current lexical scope.
15151    Check for errors (such as an incompatible declaration for the same
15152    name already seen in the same scope).
15153
15154    Returns either X or an old decl for the same name.
15155    If an old decl is returned, it may have been smashed
15156    to agree with what X says.  */
15157
15158 tree
15159 pushdecl (x)
15160      tree x;
15161 {
15162   register tree t;
15163   register tree name = DECL_NAME (x);
15164   register struct binding_level *b = current_binding_level;
15165
15166   if ((TREE_CODE (x) == FUNCTION_DECL)
15167       && (DECL_INITIAL (x) == 0)
15168       && DECL_EXTERNAL (x))
15169     DECL_CONTEXT (x) = NULL_TREE;
15170   else
15171     DECL_CONTEXT (x) = current_function_decl;
15172
15173   if (name)
15174     {
15175       if (IDENTIFIER_INVENTED (name))
15176         {
15177 #if BUILT_FOR_270
15178           DECL_ARTIFICIAL (x) = 1;
15179 #endif
15180           DECL_IN_SYSTEM_HEADER (x) = 1;
15181         }
15182
15183       t = lookup_name_current_level (name);
15184
15185       assert ((t == NULL_TREE) || (DECL_CONTEXT (x) == NULL_TREE));
15186
15187       /* Don't push non-parms onto list for parms until we understand
15188          why we're doing this and whether it works.  */
15189
15190       assert ((b == global_binding_level)
15191               || !ffecom_transform_only_dummies_
15192               || TREE_CODE (x) == PARM_DECL);
15193
15194       if ((t != NULL_TREE) && duplicate_decls (x, t))
15195         return t;
15196
15197       /* If we are processing a typedef statement, generate a whole new
15198          ..._TYPE node (which will be just an variant of the existing
15199          ..._TYPE node with identical properties) and then install the
15200          TYPE_DECL node generated to represent the typedef name as the
15201          TYPE_NAME of this brand new (duplicate) ..._TYPE node.
15202
15203          The whole point here is to end up with a situation where each and every
15204          ..._TYPE node the compiler creates will be uniquely associated with
15205          AT MOST one node representing a typedef name. This way, even though
15206          the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
15207          (i.e. "typedef name") nodes very early on, later parts of the
15208          compiler can always do the reverse translation and get back the
15209          corresponding typedef name.  For example, given:
15210
15211          typedef struct S MY_TYPE; MY_TYPE object;
15212
15213          Later parts of the compiler might only know that `object' was of type
15214          `struct S' if it were not for code just below.  With this code
15215          however, later parts of the compiler see something like:
15216
15217          struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
15218
15219          And they can then deduce (from the node for type struct S') that the
15220          original object declaration was:
15221
15222          MY_TYPE object;
15223
15224          Being able to do this is important for proper support of protoize, and
15225          also for generating precise symbolic debugging information which
15226          takes full account of the programmer's (typedef) vocabulary.
15227
15228          Obviously, we don't want to generate a duplicate ..._TYPE node if the
15229          TYPE_DECL node that we are now processing really represents a
15230          standard built-in type.
15231
15232          Since all standard types are effectively declared at line zero in the
15233          source file, we can easily check to see if we are working on a
15234          standard type by checking the current value of lineno.  */
15235
15236       if (TREE_CODE (x) == TYPE_DECL)
15237         {
15238           if (DECL_SOURCE_LINE (x) == 0)
15239             {
15240               if (TYPE_NAME (TREE_TYPE (x)) == 0)
15241                 TYPE_NAME (TREE_TYPE (x)) = x;
15242             }
15243           else if (TREE_TYPE (x) != error_mark_node)
15244             {
15245               tree tt = TREE_TYPE (x);
15246
15247               tt = build_type_copy (tt);
15248               TYPE_NAME (tt) = x;
15249               TREE_TYPE (x) = tt;
15250             }
15251         }
15252
15253       /* This name is new in its binding level. Install the new declaration
15254          and return it.  */
15255       if (b == global_binding_level)
15256         IDENTIFIER_GLOBAL_VALUE (name) = x;
15257       else
15258         IDENTIFIER_LOCAL_VALUE (name) = x;
15259     }
15260
15261   /* Put decls on list in reverse order. We will reverse them later if
15262      necessary.  */
15263   TREE_CHAIN (x) = b->names;
15264   b->names = x;
15265
15266   return x;
15267 }
15268
15269 /* Nonzero if the current level needs to have a BLOCK made.  */
15270
15271 static int
15272 kept_level_p ()
15273 {
15274   tree decl;
15275
15276   for (decl = current_binding_level->names;
15277        decl;
15278        decl = TREE_CHAIN (decl))
15279     {
15280       if (TREE_USED (decl) || TREE_CODE (decl) != VAR_DECL
15281           || (DECL_NAME (decl) && ! DECL_ARTIFICIAL (decl)))
15282         /* Currently, there aren't supposed to be non-artificial names
15283            at other than the top block for a function -- they're
15284            believed to always be temps.  But it's wise to check anyway.  */
15285         return 1;
15286     }
15287   return 0;
15288 }
15289
15290 /* Enter a new binding level.
15291    If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
15292    not for that of tags.  */
15293
15294 void
15295 pushlevel (tag_transparent)
15296      int tag_transparent;
15297 {
15298   register struct binding_level *newlevel = NULL_BINDING_LEVEL;
15299
15300   assert (! tag_transparent);
15301
15302   if (current_binding_level == global_binding_level)
15303     {
15304       named_labels = 0;
15305     }
15306
15307   /* Reuse or create a struct for this binding level.  */
15308
15309   if (free_binding_level)
15310     {
15311       newlevel = free_binding_level;
15312       free_binding_level = free_binding_level->level_chain;
15313     }
15314   else
15315     {
15316       newlevel = make_binding_level ();
15317     }
15318
15319   /* Add this level to the front of the chain (stack) of levels that
15320      are active.  */
15321
15322   *newlevel = clear_binding_level;
15323   newlevel->level_chain = current_binding_level;
15324   current_binding_level = newlevel;
15325 }
15326
15327 /* Set the BLOCK node for the innermost scope
15328    (the one we are currently in).  */
15329
15330 void
15331 set_block (block)
15332      register tree block;
15333 {
15334   current_binding_level->this_block = block;
15335 }
15336
15337 /* ~~gcc/tree.h *should* declare this, because toplev.c references it.  */
15338
15339 /* Can't 'yydebug' a front end not generated by yacc/bison!  */
15340
15341 void
15342 set_yydebug (value)
15343      int value;
15344 {
15345   if (value)
15346     fprintf (stderr, "warning: no yacc/bison-generated output to debug!\n");
15347 }
15348
15349 tree
15350 signed_or_unsigned_type (unsignedp, type)
15351      int unsignedp;
15352      tree type;
15353 {
15354   tree type2;
15355
15356   if (! INTEGRAL_TYPE_P (type))
15357     return type;
15358   if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
15359     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15360   if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
15361     return unsignedp ? unsigned_type_node : integer_type_node;
15362   if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
15363     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15364   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
15365     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15366   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
15367     return (unsignedp ? long_long_unsigned_type_node
15368             : long_long_integer_type_node);
15369
15370   type2 = type_for_size (TYPE_PRECISION (type), unsignedp);
15371   if (type2 == NULL_TREE)
15372     return type;
15373
15374   return type2;
15375 }
15376
15377 tree
15378 signed_type (type)
15379      tree type;
15380 {
15381   tree type1 = TYPE_MAIN_VARIANT (type);
15382   ffeinfoKindtype kt;
15383   tree type2;
15384
15385   if (type1 == unsigned_char_type_node || type1 == char_type_node)
15386     return signed_char_type_node;
15387   if (type1 == unsigned_type_node)
15388     return integer_type_node;
15389   if (type1 == short_unsigned_type_node)
15390     return short_integer_type_node;
15391   if (type1 == long_unsigned_type_node)
15392     return long_integer_type_node;
15393   if (type1 == long_long_unsigned_type_node)
15394     return long_long_integer_type_node;
15395 #if 0   /* gcc/c-* files only */
15396   if (type1 == unsigned_intDI_type_node)
15397     return intDI_type_node;
15398   if (type1 == unsigned_intSI_type_node)
15399     return intSI_type_node;
15400   if (type1 == unsigned_intHI_type_node)
15401     return intHI_type_node;
15402   if (type1 == unsigned_intQI_type_node)
15403     return intQI_type_node;
15404 #endif
15405
15406   type2 = type_for_size (TYPE_PRECISION (type1), 0);
15407   if (type2 != NULL_TREE)
15408     return type2;
15409
15410   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15411     {
15412       type2 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15413
15414       if (type1 == type2)
15415         return ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15416     }
15417
15418   return type;
15419 }
15420
15421 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
15422    or validate its data type for an `if' or `while' statement or ?..: exp.
15423
15424    This preparation consists of taking the ordinary
15425    representation of an expression expr and producing a valid tree
15426    boolean expression describing whether expr is nonzero.  We could
15427    simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
15428    but we optimize comparisons, &&, ||, and !.
15429
15430    The resulting type should always be `integer_type_node'.  */
15431
15432 tree
15433 truthvalue_conversion (expr)
15434      tree expr;
15435 {
15436   if (TREE_CODE (expr) == ERROR_MARK)
15437     return expr;
15438
15439 #if 0 /* This appears to be wrong for C++.  */
15440   /* These really should return error_mark_node after 2.4 is stable.
15441      But not all callers handle ERROR_MARK properly.  */
15442   switch (TREE_CODE (TREE_TYPE (expr)))
15443     {
15444     case RECORD_TYPE:
15445       error ("struct type value used where scalar is required");
15446       return integer_zero_node;
15447
15448     case UNION_TYPE:
15449       error ("union type value used where scalar is required");
15450       return integer_zero_node;
15451
15452     case ARRAY_TYPE:
15453       error ("array type value used where scalar is required");
15454       return integer_zero_node;
15455
15456     default:
15457       break;
15458     }
15459 #endif /* 0 */
15460
15461   switch (TREE_CODE (expr))
15462     {
15463       /* It is simpler and generates better code to have only TRUTH_*_EXPR
15464          or comparison expressions as truth values at this level.  */
15465 #if 0
15466     case COMPONENT_REF:
15467       /* A one-bit unsigned bit-field is already acceptable.  */
15468       if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr, 1)))
15469           && TREE_UNSIGNED (TREE_OPERAND (expr, 1)))
15470         return expr;
15471       break;
15472 #endif
15473
15474     case EQ_EXPR:
15475       /* It is simpler and generates better code to have only TRUTH_*_EXPR
15476          or comparison expressions as truth values at this level.  */
15477 #if 0
15478       if (integer_zerop (TREE_OPERAND (expr, 1)))
15479         return build_unary_op (TRUTH_NOT_EXPR, TREE_OPERAND (expr, 0), 0);
15480 #endif
15481     case NE_EXPR: case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR:
15482     case TRUTH_ANDIF_EXPR:
15483     case TRUTH_ORIF_EXPR:
15484     case TRUTH_AND_EXPR:
15485     case TRUTH_OR_EXPR:
15486     case TRUTH_XOR_EXPR:
15487       TREE_TYPE (expr) = integer_type_node;
15488       return expr;
15489
15490     case ERROR_MARK:
15491       return expr;
15492
15493     case INTEGER_CST:
15494       return integer_zerop (expr) ? integer_zero_node : integer_one_node;
15495
15496     case REAL_CST:
15497       return real_zerop (expr) ? integer_zero_node : integer_one_node;
15498
15499     case ADDR_EXPR:
15500       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 0)))
15501         return build (COMPOUND_EXPR, integer_type_node,
15502                       TREE_OPERAND (expr, 0), integer_one_node);
15503       else
15504         return integer_one_node;
15505
15506     case COMPLEX_EXPR:
15507       return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1))
15508                         ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
15509                        integer_type_node,
15510                        truthvalue_conversion (TREE_OPERAND (expr, 0)),
15511                        truthvalue_conversion (TREE_OPERAND (expr, 1)));
15512
15513     case NEGATE_EXPR:
15514     case ABS_EXPR:
15515     case FLOAT_EXPR:
15516     case FFS_EXPR:
15517       /* These don't change whether an object is non-zero or zero.  */
15518       return truthvalue_conversion (TREE_OPERAND (expr, 0));
15519
15520     case LROTATE_EXPR:
15521     case RROTATE_EXPR:
15522       /* These don't change whether an object is zero or non-zero, but
15523          we can't ignore them if their second arg has side-effects.  */
15524       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)))
15525         return build (COMPOUND_EXPR, integer_type_node, TREE_OPERAND (expr, 1),
15526                       truthvalue_conversion (TREE_OPERAND (expr, 0)));
15527       else
15528         return truthvalue_conversion (TREE_OPERAND (expr, 0));
15529
15530     case COND_EXPR:
15531       /* Distribute the conversion into the arms of a COND_EXPR.  */
15532       return fold (build (COND_EXPR, integer_type_node, TREE_OPERAND (expr, 0),
15533                           truthvalue_conversion (TREE_OPERAND (expr, 1)),
15534                           truthvalue_conversion (TREE_OPERAND (expr, 2))));
15535
15536     case CONVERT_EXPR:
15537       /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
15538          since that affects how `default_conversion' will behave.  */
15539       if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE
15540           || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE)
15541         break;
15542       /* fall through... */
15543     case NOP_EXPR:
15544       /* If this is widening the argument, we can ignore it.  */
15545       if (TYPE_PRECISION (TREE_TYPE (expr))
15546           >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0))))
15547         return truthvalue_conversion (TREE_OPERAND (expr, 0));
15548       break;
15549
15550     case MINUS_EXPR:
15551       /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
15552          this case.  */
15553       if (TARGET_FLOAT_FORMAT == IEEE_FLOAT_FORMAT
15554           && TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE)
15555         break;
15556       /* fall through... */
15557     case BIT_XOR_EXPR:
15558       /* This and MINUS_EXPR can be changed into a comparison of the
15559          two objects.  */
15560       if (TREE_TYPE (TREE_OPERAND (expr, 0))
15561           == TREE_TYPE (TREE_OPERAND (expr, 1)))
15562         return ffecom_2 (NE_EXPR, integer_type_node,
15563                          TREE_OPERAND (expr, 0),
15564                          TREE_OPERAND (expr, 1));
15565       return ffecom_2 (NE_EXPR, integer_type_node,
15566                        TREE_OPERAND (expr, 0),
15567                        fold (build1 (NOP_EXPR,
15568                                      TREE_TYPE (TREE_OPERAND (expr, 0)),
15569                                      TREE_OPERAND (expr, 1))));
15570
15571     case BIT_AND_EXPR:
15572       if (integer_onep (TREE_OPERAND (expr, 1)))
15573         return expr;
15574       break;
15575
15576     case MODIFY_EXPR:
15577 #if 0                           /* No such thing in Fortran. */
15578       if (warn_parentheses && C_EXP_ORIGINAL_CODE (expr) == MODIFY_EXPR)
15579         warning ("suggest parentheses around assignment used as truth value");
15580 #endif
15581       break;
15582
15583     default:
15584       break;
15585     }
15586
15587   if (TREE_CODE (TREE_TYPE (expr)) == COMPLEX_TYPE)
15588     return (ffecom_2
15589             ((TREE_SIDE_EFFECTS (expr)
15590               ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
15591              integer_type_node,
15592              truthvalue_conversion (ffecom_1 (REALPART_EXPR,
15593                                               TREE_TYPE (TREE_TYPE (expr)),
15594                                               expr)),
15595              truthvalue_conversion (ffecom_1 (IMAGPART_EXPR,
15596                                               TREE_TYPE (TREE_TYPE (expr)),
15597                                               expr))));
15598
15599   return ffecom_2 (NE_EXPR, integer_type_node,
15600                    expr,
15601                    convert (TREE_TYPE (expr), integer_zero_node));
15602 }
15603
15604 tree
15605 type_for_mode (mode, unsignedp)
15606      enum machine_mode mode;
15607      int unsignedp;
15608 {
15609   int i;
15610   int j;
15611   tree t;
15612
15613   if (mode == TYPE_MODE (integer_type_node))
15614     return unsignedp ? unsigned_type_node : integer_type_node;
15615
15616   if (mode == TYPE_MODE (signed_char_type_node))
15617     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15618
15619   if (mode == TYPE_MODE (short_integer_type_node))
15620     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15621
15622   if (mode == TYPE_MODE (long_integer_type_node))
15623     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15624
15625   if (mode == TYPE_MODE (long_long_integer_type_node))
15626     return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node;
15627
15628 #if HOST_BITS_PER_WIDE_INT >= 64
15629   if (mode == TYPE_MODE (intTI_type_node))
15630     return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
15631 #endif
15632
15633   if (mode == TYPE_MODE (float_type_node))
15634     return float_type_node;
15635
15636   if (mode == TYPE_MODE (double_type_node))
15637     return double_type_node;
15638
15639   if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
15640     return build_pointer_type (char_type_node);
15641
15642   if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
15643     return build_pointer_type (integer_type_node);
15644
15645   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
15646     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
15647       {
15648         if (((t = ffecom_tree_type[i][j]) != NULL_TREE)
15649             && (mode == TYPE_MODE (t)))
15650           {
15651             if ((i == FFEINFO_basictypeINTEGER) && unsignedp)
15652               return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][j];
15653             else
15654               return t;
15655           }
15656       }
15657
15658   return 0;
15659 }
15660
15661 tree
15662 type_for_size (bits, unsignedp)
15663      unsigned bits;
15664      int unsignedp;
15665 {
15666   ffeinfoKindtype kt;
15667   tree type_node;
15668
15669   if (bits == TYPE_PRECISION (integer_type_node))
15670     return unsignedp ? unsigned_type_node : integer_type_node;
15671
15672   if (bits == TYPE_PRECISION (signed_char_type_node))
15673     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15674
15675   if (bits == TYPE_PRECISION (short_integer_type_node))
15676     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15677
15678   if (bits == TYPE_PRECISION (long_integer_type_node))
15679     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15680
15681   if (bits == TYPE_PRECISION (long_long_integer_type_node))
15682     return (unsignedp ? long_long_unsigned_type_node
15683             : long_long_integer_type_node);
15684
15685   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15686     {
15687       type_node = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15688
15689       if ((type_node != NULL_TREE) && (bits == TYPE_PRECISION (type_node)))
15690         return unsignedp ? ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]
15691           : type_node;
15692     }
15693
15694   return 0;
15695 }
15696
15697 tree
15698 unsigned_type (type)
15699      tree type;
15700 {
15701   tree type1 = TYPE_MAIN_VARIANT (type);
15702   ffeinfoKindtype kt;
15703   tree type2;
15704
15705   if (type1 == signed_char_type_node || type1 == char_type_node)
15706     return unsigned_char_type_node;
15707   if (type1 == integer_type_node)
15708     return unsigned_type_node;
15709   if (type1 == short_integer_type_node)
15710     return short_unsigned_type_node;
15711   if (type1 == long_integer_type_node)
15712     return long_unsigned_type_node;
15713   if (type1 == long_long_integer_type_node)
15714     return long_long_unsigned_type_node;
15715 #if 0   /* gcc/c-* files only */
15716   if (type1 == intDI_type_node)
15717     return unsigned_intDI_type_node;
15718   if (type1 == intSI_type_node)
15719     return unsigned_intSI_type_node;
15720   if (type1 == intHI_type_node)
15721     return unsigned_intHI_type_node;
15722   if (type1 == intQI_type_node)
15723     return unsigned_intQI_type_node;
15724 #endif
15725
15726   type2 = type_for_size (TYPE_PRECISION (type1), 1);
15727   if (type2 != NULL_TREE)
15728     return type2;
15729
15730   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15731     {
15732       type2 = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15733
15734       if (type1 == type2)
15735         return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15736     }
15737
15738   return type;
15739 }
15740
15741 /* Callback routines for garbage collection.  */
15742
15743 int ggc_p = 1;
15744
15745 void
15746 lang_mark_tree (t)
15747      union tree_node *t ATTRIBUTE_UNUSED;
15748 {
15749   if (TREE_CODE (t) == IDENTIFIER_NODE)
15750     {
15751       struct lang_identifier *i = (struct lang_identifier *) t;
15752       ggc_mark_tree (IDENTIFIER_GLOBAL_VALUE (i));
15753       ggc_mark_tree (IDENTIFIER_LOCAL_VALUE (i));
15754       ggc_mark_tree (IDENTIFIER_LABEL_VALUE (i));
15755     }
15756   else if (TYPE_P (t) && TYPE_LANG_SPECIFIC (t))
15757     ggc_mark (TYPE_LANG_SPECIFIC (t));
15758 }
15759
15760 void
15761 lang_mark_false_label_stack (l)
15762      struct label_node *l;
15763 {
15764   /* Fortran doesn't use false_label_stack.  It better be NULL.  */
15765   if (l != NULL)
15766     abort();
15767 }
15768
15769 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
15770 \f
15771 #if FFECOM_GCC_INCLUDE
15772
15773 /* From gcc/cccp.c, the code to handle -I.  */
15774
15775 /* Skip leading "./" from a directory name.
15776    This may yield the empty string, which represents the current directory.  */
15777
15778 static const char *
15779 skip_redundant_dir_prefix (const char *dir)
15780 {
15781   while (dir[0] == '.' && dir[1] == '/')
15782     for (dir += 2; *dir == '/'; dir++)
15783       continue;
15784   if (dir[0] == '.' && !dir[1])
15785     dir++;
15786   return dir;
15787 }
15788
15789 /* The file_name_map structure holds a mapping of file names for a
15790    particular directory.  This mapping is read from the file named
15791    FILE_NAME_MAP_FILE in that directory.  Such a file can be used to
15792    map filenames on a file system with severe filename restrictions,
15793    such as DOS.  The format of the file name map file is just a series
15794    of lines with two tokens on each line.  The first token is the name
15795    to map, and the second token is the actual name to use.  */
15796
15797 struct file_name_map
15798 {
15799   struct file_name_map *map_next;
15800   char *map_from;
15801   char *map_to;
15802 };
15803
15804 #define FILE_NAME_MAP_FILE "header.gcc"
15805
15806 /* Current maximum length of directory names in the search path
15807    for include files.  (Altered as we get more of them.)  */
15808
15809 static int max_include_len = 0;
15810
15811 struct file_name_list
15812   {
15813     struct file_name_list *next;
15814     char *fname;
15815     /* Mapping of file names for this directory.  */
15816     struct file_name_map *name_map;
15817     /* Non-zero if name_map is valid.  */
15818     int got_name_map;
15819   };
15820
15821 static struct file_name_list *include = NULL;   /* First dir to search */
15822 static struct file_name_list *last_include = NULL;      /* Last in chain */
15823
15824 /* I/O buffer structure.
15825    The `fname' field is nonzero for source files and #include files
15826    and for the dummy text used for -D and -U.
15827    It is zero for rescanning results of macro expansion
15828    and for expanding macro arguments.  */
15829 #define INPUT_STACK_MAX 400
15830 static struct file_buf {
15831   const char *fname;
15832   /* Filename specified with #line command.  */
15833   const char *nominal_fname;
15834   /* Record where in the search path this file was found.
15835      For #include_next.  */
15836   struct file_name_list *dir;
15837   ffewhereLine line;
15838   ffewhereColumn column;
15839 } instack[INPUT_STACK_MAX];
15840
15841 static int last_error_tick = 0;    /* Incremented each time we print it.  */
15842 static int input_file_stack_tick = 0;  /* Incremented when status changes.  */
15843
15844 /* Current nesting level of input sources.
15845    `instack[indepth]' is the level currently being read.  */
15846 static int indepth = -1;
15847
15848 typedef struct file_buf FILE_BUF;
15849
15850 typedef unsigned char U_CHAR;
15851
15852 /* table to tell if char can be part of a C identifier. */
15853 U_CHAR is_idchar[256];
15854 /* table to tell if char can be first char of a c identifier. */
15855 U_CHAR is_idstart[256];
15856 /* table to tell if c is horizontal space.  */
15857 U_CHAR is_hor_space[256];
15858 /* table to tell if c is horizontal or vertical space.  */
15859 static U_CHAR is_space[256];
15860
15861 #define SKIP_WHITE_SPACE(p) do { while (is_hor_space[*p]) p++; } while (0)
15862 #define SKIP_ALL_WHITE_SPACE(p) do { while (is_space[*p]) p++; } while (0)
15863
15864 /* Nonzero means -I- has been seen,
15865    so don't look for #include "foo" the source-file directory.  */
15866 static int ignore_srcdir;
15867
15868 #ifndef INCLUDE_LEN_FUDGE
15869 #define INCLUDE_LEN_FUDGE 0
15870 #endif
15871
15872 static void append_include_chain (struct file_name_list *first,
15873                                   struct file_name_list *last);
15874 static FILE *open_include_file (char *filename,
15875                                 struct file_name_list *searchptr);
15876 static void print_containing_files (ffebadSeverity sev);
15877 static const char *skip_redundant_dir_prefix (const char *);
15878 static char *read_filename_string (int ch, FILE *f);
15879 static struct file_name_map *read_name_map (const char *dirname);
15880
15881 /* Append a chain of `struct file_name_list's
15882    to the end of the main include chain.
15883    FIRST is the beginning of the chain to append, and LAST is the end.  */
15884
15885 static void
15886 append_include_chain (first, last)
15887      struct file_name_list *first, *last;
15888 {
15889   struct file_name_list *dir;
15890
15891   if (!first || !last)
15892     return;
15893
15894   if (include == 0)
15895     include = first;
15896   else
15897     last_include->next = first;
15898
15899   for (dir = first; ; dir = dir->next) {
15900     int len = strlen (dir->fname) + INCLUDE_LEN_FUDGE;
15901     if (len > max_include_len)
15902       max_include_len = len;
15903     if (dir == last)
15904       break;
15905   }
15906
15907   last->next = NULL;
15908   last_include = last;
15909 }
15910
15911 /* Try to open include file FILENAME.  SEARCHPTR is the directory
15912    being tried from the include file search path.  This function maps
15913    filenames on file systems based on information read by
15914    read_name_map.  */
15915
15916 static FILE *
15917 open_include_file (filename, searchptr)
15918      char *filename;
15919      struct file_name_list *searchptr;
15920 {
15921   register struct file_name_map *map;
15922   register char *from;
15923   char *p, *dir;
15924
15925   if (searchptr && ! searchptr->got_name_map)
15926     {
15927       searchptr->name_map = read_name_map (searchptr->fname
15928                                            ? searchptr->fname : ".");
15929       searchptr->got_name_map = 1;
15930     }
15931
15932   /* First check the mapping for the directory we are using.  */
15933   if (searchptr && searchptr->name_map)
15934     {
15935       from = filename;
15936       if (searchptr->fname)
15937         from += strlen (searchptr->fname) + 1;
15938       for (map = searchptr->name_map; map; map = map->map_next)
15939         {
15940           if (! strcmp (map->map_from, from))
15941             {
15942               /* Found a match.  */
15943               return fopen (map->map_to, "r");
15944             }
15945         }
15946     }
15947
15948   /* Try to find a mapping file for the particular directory we are
15949      looking in.  Thus #include <sys/types.h> will look up sys/types.h
15950      in /usr/include/header.gcc and look up types.h in
15951      /usr/include/sys/header.gcc.  */
15952   p = rindex (filename, '/');
15953 #ifdef DIR_SEPARATOR
15954   if (! p) p = rindex (filename, DIR_SEPARATOR);
15955   else {
15956     char *tmp = rindex (filename, DIR_SEPARATOR);
15957     if (tmp != NULL && tmp > p) p = tmp;
15958   }
15959 #endif
15960   if (! p)
15961     p = filename;
15962   if (searchptr
15963       && searchptr->fname
15964       && strlen (searchptr->fname) == (size_t) (p - filename)
15965       && ! strncmp (searchptr->fname, filename, (int) (p - filename)))
15966     {
15967       /* FILENAME is in SEARCHPTR, which we've already checked.  */
15968       return fopen (filename, "r");
15969     }
15970
15971   if (p == filename)
15972     {
15973       from = filename;
15974       map = read_name_map (".");
15975     }
15976   else
15977     {
15978       dir = (char *) xmalloc (p - filename + 1);
15979       memcpy (dir, filename, p - filename);
15980       dir[p - filename] = '\0';
15981       from = p + 1;
15982       map = read_name_map (dir);
15983       free (dir);
15984     }
15985   for (; map; map = map->map_next)
15986     if (! strcmp (map->map_from, from))
15987       return fopen (map->map_to, "r");
15988
15989   return fopen (filename, "r");
15990 }
15991
15992 /* Print the file names and line numbers of the #include
15993    commands which led to the current file.  */
15994
15995 static void
15996 print_containing_files (ffebadSeverity sev)
15997 {
15998   FILE_BUF *ip = NULL;
15999   int i;
16000   int first = 1;
16001   const char *str1;
16002   const char *str2;
16003
16004   /* If stack of files hasn't changed since we last printed
16005      this info, don't repeat it.  */
16006   if (last_error_tick == input_file_stack_tick)
16007     return;
16008
16009   for (i = indepth; i >= 0; i--)
16010     if (instack[i].fname != NULL) {
16011       ip = &instack[i];
16012       break;
16013     }
16014
16015   /* Give up if we don't find a source file.  */
16016   if (ip == NULL)
16017     return;
16018
16019   /* Find the other, outer source files.  */
16020   for (i--; i >= 0; i--)
16021     if (instack[i].fname != NULL)
16022       {
16023         ip = &instack[i];
16024         if (first)
16025           {
16026             first = 0;
16027             str1 = "In file included";
16028           }
16029         else
16030           {
16031             str1 = "...          ...";
16032           }
16033
16034         if (i == 1)
16035           str2 = ":";
16036         else
16037           str2 = "";
16038
16039         ffebad_start_msg ("%A from %B at %0%C", sev);
16040         ffebad_here (0, ip->line, ip->column);
16041         ffebad_string (str1);
16042         ffebad_string (ip->nominal_fname);
16043         ffebad_string (str2);
16044         ffebad_finish ();
16045       }
16046
16047   /* Record we have printed the status as of this time.  */
16048   last_error_tick = input_file_stack_tick;
16049 }
16050
16051 /* Read a space delimited string of unlimited length from a stdio
16052    file.  */
16053
16054 static char *
16055 read_filename_string (ch, f)
16056      int ch;
16057      FILE *f;
16058 {
16059   char *alloc, *set;
16060   int len;
16061
16062   len = 20;
16063   set = alloc = xmalloc (len + 1);
16064   if (! is_space[ch])
16065     {
16066       *set++ = ch;
16067       while ((ch = getc (f)) != EOF && ! is_space[ch])
16068         {
16069           if (set - alloc == len)
16070             {
16071               len *= 2;
16072               alloc = xrealloc (alloc, len + 1);
16073               set = alloc + len / 2;
16074             }
16075           *set++ = ch;
16076         }
16077     }
16078   *set = '\0';
16079   ungetc (ch, f);
16080   return alloc;
16081 }
16082
16083 /* Read the file name map file for DIRNAME.  */
16084
16085 static struct file_name_map *
16086 read_name_map (dirname)
16087      const char *dirname;
16088 {
16089   /* This structure holds a linked list of file name maps, one per
16090      directory.  */
16091   struct file_name_map_list
16092     {
16093       struct file_name_map_list *map_list_next;
16094       char *map_list_name;
16095       struct file_name_map *map_list_map;
16096     };
16097   static struct file_name_map_list *map_list;
16098   register struct file_name_map_list *map_list_ptr;
16099   char *name;
16100   FILE *f;
16101   size_t dirlen;
16102   int separator_needed;
16103
16104   dirname = skip_redundant_dir_prefix (dirname);
16105
16106   for (map_list_ptr = map_list; map_list_ptr;
16107        map_list_ptr = map_list_ptr->map_list_next)
16108     if (! strcmp (map_list_ptr->map_list_name, dirname))
16109       return map_list_ptr->map_list_map;
16110
16111   map_list_ptr = ((struct file_name_map_list *)
16112                   xmalloc (sizeof (struct file_name_map_list)));
16113   map_list_ptr->map_list_name = xstrdup (dirname);
16114   map_list_ptr->map_list_map = NULL;
16115
16116   dirlen = strlen (dirname);
16117   separator_needed = dirlen != 0 && dirname[dirlen - 1] != '/';
16118   name = (char *) xmalloc (dirlen + strlen (FILE_NAME_MAP_FILE) + 2);
16119   strcpy (name, dirname);
16120   name[dirlen] = '/';
16121   strcpy (name + dirlen + separator_needed, FILE_NAME_MAP_FILE);
16122   f = fopen (name, "r");
16123   free (name);
16124   if (!f)
16125     map_list_ptr->map_list_map = NULL;
16126   else
16127     {
16128       int ch;
16129
16130       while ((ch = getc (f)) != EOF)
16131         {
16132           char *from, *to;
16133           struct file_name_map *ptr;
16134
16135           if (is_space[ch])
16136             continue;
16137           from = read_filename_string (ch, f);
16138           while ((ch = getc (f)) != EOF && is_hor_space[ch])
16139             ;
16140           to = read_filename_string (ch, f);
16141
16142           ptr = ((struct file_name_map *)
16143                  xmalloc (sizeof (struct file_name_map)));
16144           ptr->map_from = from;
16145
16146           /* Make the real filename absolute.  */
16147           if (*to == '/')
16148             ptr->map_to = to;
16149           else
16150             {
16151               ptr->map_to = xmalloc (dirlen + strlen (to) + 2);
16152               strcpy (ptr->map_to, dirname);
16153               ptr->map_to[dirlen] = '/';
16154               strcpy (ptr->map_to + dirlen + separator_needed, to);
16155               free (to);
16156             }
16157
16158           ptr->map_next = map_list_ptr->map_list_map;
16159           map_list_ptr->map_list_map = ptr;
16160
16161           while ((ch = getc (f)) != '\n')
16162             if (ch == EOF)
16163               break;
16164         }
16165       fclose (f);
16166     }
16167
16168   map_list_ptr->map_list_next = map_list;
16169   map_list = map_list_ptr;
16170
16171   return map_list_ptr->map_list_map;
16172 }
16173
16174 static void
16175 ffecom_file_ (const char *name)
16176 {
16177   FILE_BUF *fp;
16178
16179   /* Do partial setup of input buffer for the sake of generating
16180      early #line directives (when -g is in effect).  */
16181
16182   fp = &instack[++indepth];
16183   memset ((char *) fp, 0, sizeof (FILE_BUF));
16184   if (name == NULL)
16185     name = "";
16186   fp->nominal_fname = fp->fname = name;
16187 }
16188
16189 /* Initialize syntactic classifications of characters.  */
16190
16191 static void
16192 ffecom_initialize_char_syntax_ ()
16193 {
16194   register int i;
16195
16196   /*
16197    * Set up is_idchar and is_idstart tables.  These should be
16198    * faster than saying (is_alpha (c) || c == '_'), etc.
16199    * Set up these things before calling any routines tthat
16200    * refer to them.
16201    */
16202   for (i = 'a'; i <= 'z'; i++) {
16203     is_idchar[i - 'a' + 'A'] = 1;
16204     is_idchar[i] = 1;
16205     is_idstart[i - 'a' + 'A'] = 1;
16206     is_idstart[i] = 1;
16207   }
16208   for (i = '0'; i <= '9'; i++)
16209     is_idchar[i] = 1;
16210   is_idchar['_'] = 1;
16211   is_idstart['_'] = 1;
16212
16213   /* horizontal space table */
16214   is_hor_space[' '] = 1;
16215   is_hor_space['\t'] = 1;
16216   is_hor_space['\v'] = 1;
16217   is_hor_space['\f'] = 1;
16218   is_hor_space['\r'] = 1;
16219
16220   is_space[' '] = 1;
16221   is_space['\t'] = 1;
16222   is_space['\v'] = 1;
16223   is_space['\f'] = 1;
16224   is_space['\n'] = 1;
16225   is_space['\r'] = 1;
16226 }
16227
16228 static void
16229 ffecom_close_include_ (FILE *f)
16230 {
16231   fclose (f);
16232
16233   indepth--;
16234   input_file_stack_tick++;
16235
16236   ffewhere_line_kill (instack[indepth].line);
16237   ffewhere_column_kill (instack[indepth].column);
16238 }
16239
16240 static int
16241 ffecom_decode_include_option_ (char *spec)
16242 {
16243   struct file_name_list *dirtmp;
16244
16245   if (! ignore_srcdir && !strcmp (spec, "-"))
16246     ignore_srcdir = 1;
16247   else
16248     {
16249       dirtmp = (struct file_name_list *)
16250         xmalloc (sizeof (struct file_name_list));
16251       dirtmp->next = 0;         /* New one goes on the end */
16252       if (spec[0] != 0)
16253         dirtmp->fname = spec;
16254       else
16255         fatal ("Directory name must immediately follow -I option with no intervening spaces, as in `-Idir', not `-I dir'");
16256       dirtmp->got_name_map = 0;
16257       append_include_chain (dirtmp, dirtmp);
16258     }
16259   return 1;
16260 }
16261
16262 /* Open INCLUDEd file.  */
16263
16264 static FILE *
16265 ffecom_open_include_ (char *name, ffewhereLine l, ffewhereColumn c)
16266 {
16267   char *fbeg = name;
16268   size_t flen = strlen (fbeg);
16269   struct file_name_list *search_start = include; /* Chain of dirs to search */
16270   struct file_name_list dsp[1]; /* First in chain, if #include "..." */
16271   struct file_name_list *searchptr = 0;
16272   char *fname;          /* Dynamically allocated fname buffer */
16273   FILE *f;
16274   FILE_BUF *fp;
16275
16276   if (flen == 0)
16277     return NULL;
16278
16279   dsp[0].fname = NULL;
16280
16281   /* If -I- was specified, don't search current dir, only spec'd ones. */
16282   if (!ignore_srcdir)
16283     {
16284       for (fp = &instack[indepth]; fp >= instack; fp--)
16285         {
16286           int n;
16287           char *ep;
16288           const char *nam;
16289
16290           if ((nam = fp->nominal_fname) != NULL)
16291             {
16292               /* Found a named file.  Figure out dir of the file,
16293                  and put it in front of the search list.  */
16294               dsp[0].next = search_start;
16295               search_start = dsp;
16296 #ifndef VMS
16297               ep = rindex (nam, '/');
16298 #ifdef DIR_SEPARATOR
16299             if (ep == NULL) ep = rindex (nam, DIR_SEPARATOR);
16300             else {
16301               char *tmp = rindex (nam, DIR_SEPARATOR);
16302               if (tmp != NULL && tmp > ep) ep = tmp;
16303             }
16304 #endif
16305 #else                           /* VMS */
16306               ep = rindex (nam, ']');
16307               if (ep == NULL) ep = rindex (nam, '>');
16308               if (ep == NULL) ep = rindex (nam, ':');
16309               if (ep != NULL) ep++;
16310 #endif                          /* VMS */
16311               if (ep != NULL)
16312                 {
16313                   n = ep - nam;
16314                   dsp[0].fname = (char *) xmalloc (n + 1);
16315                   strncpy (dsp[0].fname, nam, n);
16316                   dsp[0].fname[n] = '\0';
16317                   if (n + INCLUDE_LEN_FUDGE > max_include_len)
16318                     max_include_len = n + INCLUDE_LEN_FUDGE;
16319                 }
16320               else
16321                 dsp[0].fname = NULL; /* Current directory */
16322               dsp[0].got_name_map = 0;
16323               break;
16324             }
16325         }
16326     }
16327
16328   /* Allocate this permanently, because it gets stored in the definitions
16329      of macros.  */
16330   fname = xmalloc (max_include_len + flen + 4);
16331   /* + 2 above for slash and terminating null.  */
16332   /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
16333      for g77 yet).  */
16334
16335   /* If specified file name is absolute, just open it.  */
16336
16337   if (*fbeg == '/'
16338 #ifdef DIR_SEPARATOR
16339       || *fbeg == DIR_SEPARATOR
16340 #endif
16341       )
16342     {
16343       strncpy (fname, (char *) fbeg, flen);
16344       fname[flen] = 0;
16345       f = open_include_file (fname, NULL_PTR);
16346     }
16347   else
16348     {
16349       f = NULL;
16350
16351       /* Search directory path, trying to open the file.
16352          Copy each filename tried into FNAME.  */
16353
16354       for (searchptr = search_start; searchptr; searchptr = searchptr->next)
16355         {
16356           if (searchptr->fname)
16357             {
16358               /* The empty string in a search path is ignored.
16359                  This makes it possible to turn off entirely
16360                  a standard piece of the list.  */
16361               if (searchptr->fname[0] == 0)
16362                 continue;
16363               strcpy (fname, skip_redundant_dir_prefix (searchptr->fname));
16364               if (fname[0] && fname[strlen (fname) - 1] != '/')
16365                 strcat (fname, "/");
16366               fname[strlen (fname) + flen] = 0;
16367             }
16368           else
16369             fname[0] = 0;
16370
16371           strncat (fname, fbeg, flen);
16372 #ifdef VMS
16373           /* Change this 1/2 Unix 1/2 VMS file specification into a
16374              full VMS file specification */
16375           if (searchptr->fname && (searchptr->fname[0] != 0))
16376             {
16377               /* Fix up the filename */
16378               hack_vms_include_specification (fname);
16379             }
16380           else
16381             {
16382               /* This is a normal VMS filespec, so use it unchanged.  */
16383               strncpy (fname, (char *) fbeg, flen);
16384               fname[flen] = 0;
16385 #if 0   /* Not for g77.  */
16386               /* if it's '#include filename', add the missing .h */
16387               if (index (fname, '.') == NULL)
16388                 strcat (fname, ".h");
16389 #endif
16390             }
16391 #endif /* VMS */
16392           f = open_include_file (fname, searchptr);
16393 #ifdef EACCES
16394           if (f == NULL && errno == EACCES)
16395             {
16396               print_containing_files (FFEBAD_severityWARNING);
16397               ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
16398                                 FFEBAD_severityWARNING);
16399               ffebad_string (fname);
16400               ffebad_here (0, l, c);
16401               ffebad_finish ();
16402             }
16403 #endif
16404           if (f != NULL)
16405             break;
16406         }
16407     }
16408
16409   if (f == NULL)
16410     {
16411       /* A file that was not found.  */
16412
16413       strncpy (fname, (char *) fbeg, flen);
16414       fname[flen] = 0;
16415       print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE));
16416       ffebad_start (FFEBAD_OPEN_INCLUDE);
16417       ffebad_here (0, l, c);
16418       ffebad_string (fname);
16419       ffebad_finish ();
16420     }
16421
16422   if (dsp[0].fname != NULL)
16423     free (dsp[0].fname);
16424
16425   if (f == NULL)
16426     return NULL;
16427
16428   if (indepth >= (INPUT_STACK_MAX - 1))
16429     {
16430       print_containing_files (FFEBAD_severityFATAL);
16431       ffebad_start_msg ("At %0, INCLUDE nesting too deep",
16432                         FFEBAD_severityFATAL);
16433       ffebad_string (fname);
16434       ffebad_here (0, l, c);
16435       ffebad_finish ();
16436       return NULL;
16437     }
16438
16439   instack[indepth].line = ffewhere_line_use (l);
16440   instack[indepth].column = ffewhere_column_use (c);
16441
16442   fp = &instack[indepth + 1];
16443   memset ((char *) fp, 0, sizeof (FILE_BUF));
16444   fp->nominal_fname = fp->fname = fname;
16445   fp->dir = searchptr;
16446
16447   indepth++;
16448   input_file_stack_tick++;
16449
16450   return f;
16451 }
16452 #endif  /* FFECOM_GCC_INCLUDE */
16453
16454 /**INDENT* (Do not reformat this comment even with -fca option.)
16455    Data-gathering files: Given the source file listed below, compiled with
16456    f2c I obtained the output file listed after that, and from the output
16457    file I derived the above code.
16458
16459 -------- (begin input file to f2c)
16460         implicit none
16461         character*10 A1,A2
16462         complex C1,C2
16463         integer I1,I2
16464         real R1,R2
16465         double precision D1,D2
16466 C
16467         call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
16468 c /
16469         call fooI(I1/I2)
16470         call fooR(R1/I1)
16471         call fooD(D1/I1)
16472         call fooC(C1/I1)
16473         call fooR(R1/R2)
16474         call fooD(R1/D1)
16475         call fooD(D1/D2)
16476         call fooD(D1/R1)
16477         call fooC(C1/C2)
16478         call fooC(C1/R1)
16479         call fooZ(C1/D1)
16480 c **
16481         call fooI(I1**I2)
16482         call fooR(R1**I1)
16483         call fooD(D1**I1)
16484         call fooC(C1**I1)
16485         call fooR(R1**R2)
16486         call fooD(R1**D1)
16487         call fooD(D1**D2)
16488         call fooD(D1**R1)
16489         call fooC(C1**C2)
16490         call fooC(C1**R1)
16491         call fooZ(C1**D1)
16492 c FFEINTRIN_impABS
16493         call fooR(ABS(R1))
16494 c FFEINTRIN_impACOS
16495         call fooR(ACOS(R1))
16496 c FFEINTRIN_impAIMAG
16497         call fooR(AIMAG(C1))
16498 c FFEINTRIN_impAINT
16499         call fooR(AINT(R1))
16500 c FFEINTRIN_impALOG
16501         call fooR(ALOG(R1))
16502 c FFEINTRIN_impALOG10
16503         call fooR(ALOG10(R1))
16504 c FFEINTRIN_impAMAX0
16505         call fooR(AMAX0(I1,I2))
16506 c FFEINTRIN_impAMAX1
16507         call fooR(AMAX1(R1,R2))
16508 c FFEINTRIN_impAMIN0
16509         call fooR(AMIN0(I1,I2))
16510 c FFEINTRIN_impAMIN1
16511         call fooR(AMIN1(R1,R2))
16512 c FFEINTRIN_impAMOD
16513         call fooR(AMOD(R1,R2))
16514 c FFEINTRIN_impANINT
16515         call fooR(ANINT(R1))
16516 c FFEINTRIN_impASIN
16517         call fooR(ASIN(R1))
16518 c FFEINTRIN_impATAN
16519         call fooR(ATAN(R1))
16520 c FFEINTRIN_impATAN2
16521         call fooR(ATAN2(R1,R2))
16522 c FFEINTRIN_impCABS
16523         call fooR(CABS(C1))
16524 c FFEINTRIN_impCCOS
16525         call fooC(CCOS(C1))
16526 c FFEINTRIN_impCEXP
16527         call fooC(CEXP(C1))
16528 c FFEINTRIN_impCHAR
16529         call fooA(CHAR(I1))
16530 c FFEINTRIN_impCLOG
16531         call fooC(CLOG(C1))
16532 c FFEINTRIN_impCONJG
16533         call fooC(CONJG(C1))
16534 c FFEINTRIN_impCOS
16535         call fooR(COS(R1))
16536 c FFEINTRIN_impCOSH
16537         call fooR(COSH(R1))
16538 c FFEINTRIN_impCSIN
16539         call fooC(CSIN(C1))
16540 c FFEINTRIN_impCSQRT
16541         call fooC(CSQRT(C1))
16542 c FFEINTRIN_impDABS
16543         call fooD(DABS(D1))
16544 c FFEINTRIN_impDACOS
16545         call fooD(DACOS(D1))
16546 c FFEINTRIN_impDASIN
16547         call fooD(DASIN(D1))
16548 c FFEINTRIN_impDATAN
16549         call fooD(DATAN(D1))
16550 c FFEINTRIN_impDATAN2
16551         call fooD(DATAN2(D1,D2))
16552 c FFEINTRIN_impDCOS
16553         call fooD(DCOS(D1))
16554 c FFEINTRIN_impDCOSH
16555         call fooD(DCOSH(D1))
16556 c FFEINTRIN_impDDIM
16557         call fooD(DDIM(D1,D2))
16558 c FFEINTRIN_impDEXP
16559         call fooD(DEXP(D1))
16560 c FFEINTRIN_impDIM
16561         call fooR(DIM(R1,R2))
16562 c FFEINTRIN_impDINT
16563         call fooD(DINT(D1))
16564 c FFEINTRIN_impDLOG
16565         call fooD(DLOG(D1))
16566 c FFEINTRIN_impDLOG10
16567         call fooD(DLOG10(D1))
16568 c FFEINTRIN_impDMAX1
16569         call fooD(DMAX1(D1,D2))
16570 c FFEINTRIN_impDMIN1
16571         call fooD(DMIN1(D1,D2))
16572 c FFEINTRIN_impDMOD
16573         call fooD(DMOD(D1,D2))
16574 c FFEINTRIN_impDNINT
16575         call fooD(DNINT(D1))
16576 c FFEINTRIN_impDPROD
16577         call fooD(DPROD(R1,R2))
16578 c FFEINTRIN_impDSIGN
16579         call fooD(DSIGN(D1,D2))
16580 c FFEINTRIN_impDSIN
16581         call fooD(DSIN(D1))
16582 c FFEINTRIN_impDSINH
16583         call fooD(DSINH(D1))
16584 c FFEINTRIN_impDSQRT
16585         call fooD(DSQRT(D1))
16586 c FFEINTRIN_impDTAN
16587         call fooD(DTAN(D1))
16588 c FFEINTRIN_impDTANH
16589         call fooD(DTANH(D1))
16590 c FFEINTRIN_impEXP
16591         call fooR(EXP(R1))
16592 c FFEINTRIN_impIABS
16593         call fooI(IABS(I1))
16594 c FFEINTRIN_impICHAR
16595         call fooI(ICHAR(A1))
16596 c FFEINTRIN_impIDIM
16597         call fooI(IDIM(I1,I2))
16598 c FFEINTRIN_impIDNINT
16599         call fooI(IDNINT(D1))
16600 c FFEINTRIN_impINDEX
16601         call fooI(INDEX(A1,A2))
16602 c FFEINTRIN_impISIGN
16603         call fooI(ISIGN(I1,I2))
16604 c FFEINTRIN_impLEN
16605         call fooI(LEN(A1))
16606 c FFEINTRIN_impLGE
16607         call fooL(LGE(A1,A2))
16608 c FFEINTRIN_impLGT
16609         call fooL(LGT(A1,A2))
16610 c FFEINTRIN_impLLE
16611         call fooL(LLE(A1,A2))
16612 c FFEINTRIN_impLLT
16613         call fooL(LLT(A1,A2))
16614 c FFEINTRIN_impMAX0
16615         call fooI(MAX0(I1,I2))
16616 c FFEINTRIN_impMAX1
16617         call fooI(MAX1(R1,R2))
16618 c FFEINTRIN_impMIN0
16619         call fooI(MIN0(I1,I2))
16620 c FFEINTRIN_impMIN1
16621         call fooI(MIN1(R1,R2))
16622 c FFEINTRIN_impMOD
16623         call fooI(MOD(I1,I2))
16624 c FFEINTRIN_impNINT
16625         call fooI(NINT(R1))
16626 c FFEINTRIN_impSIGN
16627         call fooR(SIGN(R1,R2))
16628 c FFEINTRIN_impSIN
16629         call fooR(SIN(R1))
16630 c FFEINTRIN_impSINH
16631         call fooR(SINH(R1))
16632 c FFEINTRIN_impSQRT
16633         call fooR(SQRT(R1))
16634 c FFEINTRIN_impTAN
16635         call fooR(TAN(R1))
16636 c FFEINTRIN_impTANH
16637         call fooR(TANH(R1))
16638 c FFEINTRIN_imp_CMPLX_C
16639         call fooC(cmplx(C1,C2))
16640 c FFEINTRIN_imp_CMPLX_D
16641         call fooZ(cmplx(D1,D2))
16642 c FFEINTRIN_imp_CMPLX_I
16643         call fooC(cmplx(I1,I2))
16644 c FFEINTRIN_imp_CMPLX_R
16645         call fooC(cmplx(R1,R2))
16646 c FFEINTRIN_imp_DBLE_C
16647         call fooD(dble(C1))
16648 c FFEINTRIN_imp_DBLE_D
16649         call fooD(dble(D1))
16650 c FFEINTRIN_imp_DBLE_I
16651         call fooD(dble(I1))
16652 c FFEINTRIN_imp_DBLE_R
16653         call fooD(dble(R1))
16654 c FFEINTRIN_imp_INT_C
16655         call fooI(int(C1))
16656 c FFEINTRIN_imp_INT_D
16657         call fooI(int(D1))
16658 c FFEINTRIN_imp_INT_I
16659         call fooI(int(I1))
16660 c FFEINTRIN_imp_INT_R
16661         call fooI(int(R1))
16662 c FFEINTRIN_imp_REAL_C
16663         call fooR(real(C1))
16664 c FFEINTRIN_imp_REAL_D
16665         call fooR(real(D1))
16666 c FFEINTRIN_imp_REAL_I
16667         call fooR(real(I1))
16668 c FFEINTRIN_imp_REAL_R
16669         call fooR(real(R1))
16670 c
16671 c FFEINTRIN_imp_INT_D:
16672 c
16673 c FFEINTRIN_specIDINT
16674         call fooI(IDINT(D1))
16675 c
16676 c FFEINTRIN_imp_INT_R:
16677 c
16678 c FFEINTRIN_specIFIX
16679         call fooI(IFIX(R1))
16680 c FFEINTRIN_specINT
16681         call fooI(INT(R1))
16682 c
16683 c FFEINTRIN_imp_REAL_D:
16684 c
16685 c FFEINTRIN_specSNGL
16686         call fooR(SNGL(D1))
16687 c
16688 c FFEINTRIN_imp_REAL_I:
16689 c
16690 c FFEINTRIN_specFLOAT
16691         call fooR(FLOAT(I1))
16692 c FFEINTRIN_specREAL
16693         call fooR(REAL(I1))
16694 c
16695         end
16696 -------- (end input file to f2c)
16697
16698 -------- (begin output from providing above input file as input to:
16699 --------  `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
16700 --------     -e "s:^#.*$::g"')
16701
16702 //  -- translated by f2c (version 19950223).
16703    You must link the resulting object file with the libraries:
16704         -lf2c -lm   (in that order)
16705 //
16706
16707
16708 // f2c.h  --  Standard Fortran to C header file //
16709
16710 ///  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
16711
16712         - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
16713
16714
16715
16716
16717 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
16718 // we assume short, float are OK //
16719 typedef long int // long int // integer;
16720 typedef char *address;
16721 typedef short int shortint;
16722 typedef float real;
16723 typedef double doublereal;
16724 typedef struct { real r, i; } complex;
16725 typedef struct { doublereal r, i; } doublecomplex;
16726 typedef long int // long int // logical;
16727 typedef short int shortlogical;
16728 typedef char logical1;
16729 typedef char integer1;
16730 // typedef long long longint; // // system-dependent //
16731
16732
16733
16734
16735 // Extern is for use with -E //
16736
16737
16738
16739
16740 // I/O stuff //
16741
16742
16743
16744
16745
16746
16747
16748
16749 typedef long int // int or long int // flag;
16750 typedef long int // int or long int // ftnlen;
16751 typedef long int // int or long int // ftnint;
16752
16753
16754 //external read, write//
16755 typedef struct
16756 {       flag cierr;
16757         ftnint ciunit;
16758         flag ciend;
16759         char *cifmt;
16760         ftnint cirec;
16761 } cilist;
16762
16763 //internal read, write//
16764 typedef struct
16765 {       flag icierr;
16766         char *iciunit;
16767         flag iciend;
16768         char *icifmt;
16769         ftnint icirlen;
16770         ftnint icirnum;
16771 } icilist;
16772
16773 //open//
16774 typedef struct
16775 {       flag oerr;
16776         ftnint ounit;
16777         char *ofnm;
16778         ftnlen ofnmlen;
16779         char *osta;
16780         char *oacc;
16781         char *ofm;
16782         ftnint orl;
16783         char *oblnk;
16784 } olist;
16785
16786 //close//
16787 typedef struct
16788 {       flag cerr;
16789         ftnint cunit;
16790         char *csta;
16791 } cllist;
16792
16793 //rewind, backspace, endfile//
16794 typedef struct
16795 {       flag aerr;
16796         ftnint aunit;
16797 } alist;
16798
16799 // inquire //
16800 typedef struct
16801 {       flag inerr;
16802         ftnint inunit;
16803         char *infile;
16804         ftnlen infilen;
16805         ftnint  *inex;  //parameters in standard's order//
16806         ftnint  *inopen;
16807         ftnint  *innum;
16808         ftnint  *innamed;
16809         char    *inname;
16810         ftnlen  innamlen;
16811         char    *inacc;
16812         ftnlen  inacclen;
16813         char    *inseq;
16814         ftnlen  inseqlen;
16815         char    *indir;
16816         ftnlen  indirlen;
16817         char    *infmt;
16818         ftnlen  infmtlen;
16819         char    *inform;
16820         ftnint  informlen;
16821         char    *inunf;
16822         ftnlen  inunflen;
16823         ftnint  *inrecl;
16824         ftnint  *innrec;
16825         char    *inblank;
16826         ftnlen  inblanklen;
16827 } inlist;
16828
16829
16830
16831 union Multitype {       // for multiple entry points //
16832         integer1 g;
16833         shortint h;
16834         integer i;
16835         // longint j; //
16836         real r;
16837         doublereal d;
16838         complex c;
16839         doublecomplex z;
16840         };
16841
16842 typedef union Multitype Multitype;
16843
16844 typedef long Long;      // No longer used; formerly in Namelist //
16845
16846 struct Vardesc {        // for Namelist //
16847         char *name;
16848         char *addr;
16849         ftnlen *dims;
16850         int  type;
16851         };
16852 typedef struct Vardesc Vardesc;
16853
16854 struct Namelist {
16855         char *name;
16856         Vardesc **vars;
16857         int nvars;
16858         };
16859 typedef struct Namelist Namelist;
16860
16861
16862
16863
16864
16865
16866
16867
16868 // procedure parameter types for -A and -C++ //
16869
16870
16871
16872
16873 typedef int // Unknown procedure type // (*U_fp)();
16874 typedef shortint (*J_fp)();
16875 typedef integer (*I_fp)();
16876 typedef real (*R_fp)();
16877 typedef doublereal (*D_fp)(), (*E_fp)();
16878 typedef // Complex // void  (*C_fp)();
16879 typedef // Double Complex // void  (*Z_fp)();
16880 typedef logical (*L_fp)();
16881 typedef shortlogical (*K_fp)();
16882 typedef // Character // void  (*H_fp)();
16883 typedef // Subroutine // int (*S_fp)();
16884
16885 // E_fp is for real functions when -R is not specified //
16886 typedef void  C_f;      // complex function //
16887 typedef void  H_f;      // character function //
16888 typedef void  Z_f;      // double complex function //
16889 typedef doublereal E_f; // real function with -R not specified //
16890
16891 // undef any lower-case symbols that your C compiler predefines, e.g.: //
16892
16893
16894 // (No such symbols should be defined in a strict ANSI C compiler.
16895    We can avoid trouble with f2c-translated code by using
16896    gcc -ansi [-traditional].) //
16897
16898
16899
16900
16901
16902
16903
16904
16905
16906
16907
16908
16909
16910
16911
16912
16913
16914
16915
16916
16917
16918
16919
16920 // Main program // MAIN__()
16921 {
16922     // System generated locals //
16923     integer i__1;
16924     real r__1, r__2;
16925     doublereal d__1, d__2;
16926     complex q__1;
16927     doublecomplex z__1, z__2, z__3;
16928     logical L__1;
16929     char ch__1[1];
16930
16931     // Builtin functions //
16932     void c_div();
16933     integer pow_ii();
16934     double pow_ri(), pow_di();
16935     void pow_ci();
16936     double pow_dd();
16937     void pow_zz();
16938     double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
16939             asin(), atan(), atan2(), c_abs();
16940     void c_cos(), c_exp(), c_log(), r_cnjg();
16941     double cos(), cosh();
16942     void c_sin(), c_sqrt();
16943     double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
16944             d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
16945     integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
16946     logical l_ge(), l_gt(), l_le(), l_lt();
16947     integer i_nint();
16948     double r_sign();
16949
16950     // Local variables //
16951     extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
16952             fool_(), fooz_(), getem_();
16953     static char a1[10], a2[10];
16954     static complex c1, c2;
16955     static doublereal d1, d2;
16956     static integer i1, i2;
16957     static real r1, r2;
16958
16959
16960     getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
16961 // / //
16962     i__1 = i1 / i2;
16963     fooi_(&i__1);
16964     r__1 = r1 / i1;
16965     foor_(&r__1);
16966     d__1 = d1 / i1;
16967     food_(&d__1);
16968     d__1 = (doublereal) i1;
16969     q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
16970     fooc_(&q__1);
16971     r__1 = r1 / r2;
16972     foor_(&r__1);
16973     d__1 = r1 / d1;
16974     food_(&d__1);
16975     d__1 = d1 / d2;
16976     food_(&d__1);
16977     d__1 = d1 / r1;
16978     food_(&d__1);
16979     c_div(&q__1, &c1, &c2);
16980     fooc_(&q__1);
16981     q__1.r = c1.r / r1, q__1.i = c1.i / r1;
16982     fooc_(&q__1);
16983     z__1.r = c1.r / d1, z__1.i = c1.i / d1;
16984     fooz_(&z__1);
16985 // ** //
16986     i__1 = pow_ii(&i1, &i2);
16987     fooi_(&i__1);
16988     r__1 = pow_ri(&r1, &i1);
16989     foor_(&r__1);
16990     d__1 = pow_di(&d1, &i1);
16991     food_(&d__1);
16992     pow_ci(&q__1, &c1, &i1);
16993     fooc_(&q__1);
16994     d__1 = (doublereal) r1;
16995     d__2 = (doublereal) r2;
16996     r__1 = pow_dd(&d__1, &d__2);
16997     foor_(&r__1);
16998     d__2 = (doublereal) r1;
16999     d__1 = pow_dd(&d__2, &d1);
17000     food_(&d__1);
17001     d__1 = pow_dd(&d1, &d2);
17002     food_(&d__1);
17003     d__2 = (doublereal) r1;
17004     d__1 = pow_dd(&d1, &d__2);
17005     food_(&d__1);
17006     z__2.r = c1.r, z__2.i = c1.i;
17007     z__3.r = c2.r, z__3.i = c2.i;
17008     pow_zz(&z__1, &z__2, &z__3);
17009     q__1.r = z__1.r, q__1.i = z__1.i;
17010     fooc_(&q__1);
17011     z__2.r = c1.r, z__2.i = c1.i;
17012     z__3.r = r1, z__3.i = 0.;
17013     pow_zz(&z__1, &z__2, &z__3);
17014     q__1.r = z__1.r, q__1.i = z__1.i;
17015     fooc_(&q__1);
17016     z__2.r = c1.r, z__2.i = c1.i;
17017     z__3.r = d1, z__3.i = 0.;
17018     pow_zz(&z__1, &z__2, &z__3);
17019     fooz_(&z__1);
17020 // FFEINTRIN_impABS //
17021     r__1 = (doublereal)((  r1  ) >= 0 ? (  r1  ) : -(  r1  ))  ;
17022     foor_(&r__1);
17023 // FFEINTRIN_impACOS //
17024     r__1 = acos(r1);
17025     foor_(&r__1);
17026 // FFEINTRIN_impAIMAG //
17027     r__1 = r_imag(&c1);
17028     foor_(&r__1);
17029 // FFEINTRIN_impAINT //
17030     r__1 = r_int(&r1);
17031     foor_(&r__1);
17032 // FFEINTRIN_impALOG //
17033     r__1 = log(r1);
17034     foor_(&r__1);
17035 // FFEINTRIN_impALOG10 //
17036     r__1 = r_lg10(&r1);
17037     foor_(&r__1);
17038 // FFEINTRIN_impAMAX0 //
17039     r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
17040     foor_(&r__1);
17041 // FFEINTRIN_impAMAX1 //
17042     r__1 = (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
17043     foor_(&r__1);
17044 // FFEINTRIN_impAMIN0 //
17045     r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
17046     foor_(&r__1);
17047 // FFEINTRIN_impAMIN1 //
17048     r__1 = (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
17049     foor_(&r__1);
17050 // FFEINTRIN_impAMOD //
17051     r__1 = r_mod(&r1, &r2);
17052     foor_(&r__1);
17053 // FFEINTRIN_impANINT //
17054     r__1 = r_nint(&r1);
17055     foor_(&r__1);
17056 // FFEINTRIN_impASIN //
17057     r__1 = asin(r1);
17058     foor_(&r__1);
17059 // FFEINTRIN_impATAN //
17060     r__1 = atan(r1);
17061     foor_(&r__1);
17062 // FFEINTRIN_impATAN2 //
17063     r__1 = atan2(r1, r2);
17064     foor_(&r__1);
17065 // FFEINTRIN_impCABS //
17066     r__1 = c_abs(&c1);
17067     foor_(&r__1);
17068 // FFEINTRIN_impCCOS //
17069     c_cos(&q__1, &c1);
17070     fooc_(&q__1);
17071 // FFEINTRIN_impCEXP //
17072     c_exp(&q__1, &c1);
17073     fooc_(&q__1);
17074 // FFEINTRIN_impCHAR //
17075     *(unsigned char *)&ch__1[0] = i1;
17076     fooa_(ch__1, 1L);
17077 // FFEINTRIN_impCLOG //
17078     c_log(&q__1, &c1);
17079     fooc_(&q__1);
17080 // FFEINTRIN_impCONJG //
17081     r_cnjg(&q__1, &c1);
17082     fooc_(&q__1);
17083 // FFEINTRIN_impCOS //
17084     r__1 = cos(r1);
17085     foor_(&r__1);
17086 // FFEINTRIN_impCOSH //
17087     r__1 = cosh(r1);
17088     foor_(&r__1);
17089 // FFEINTRIN_impCSIN //
17090     c_sin(&q__1, &c1);
17091     fooc_(&q__1);
17092 // FFEINTRIN_impCSQRT //
17093     c_sqrt(&q__1, &c1);
17094     fooc_(&q__1);
17095 // FFEINTRIN_impDABS //
17096     d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
17097     food_(&d__1);
17098 // FFEINTRIN_impDACOS //
17099     d__1 = acos(d1);
17100     food_(&d__1);
17101 // FFEINTRIN_impDASIN //
17102     d__1 = asin(d1);
17103     food_(&d__1);
17104 // FFEINTRIN_impDATAN //
17105     d__1 = atan(d1);
17106     food_(&d__1);
17107 // FFEINTRIN_impDATAN2 //
17108     d__1 = atan2(d1, d2);
17109     food_(&d__1);
17110 // FFEINTRIN_impDCOS //
17111     d__1 = cos(d1);
17112     food_(&d__1);
17113 // FFEINTRIN_impDCOSH //
17114     d__1 = cosh(d1);
17115     food_(&d__1);
17116 // FFEINTRIN_impDDIM //
17117     d__1 = d_dim(&d1, &d2);
17118     food_(&d__1);
17119 // FFEINTRIN_impDEXP //
17120     d__1 = exp(d1);
17121     food_(&d__1);
17122 // FFEINTRIN_impDIM //
17123     r__1 = r_dim(&r1, &r2);
17124     foor_(&r__1);
17125 // FFEINTRIN_impDINT //
17126     d__1 = d_int(&d1);
17127     food_(&d__1);
17128 // FFEINTRIN_impDLOG //
17129     d__1 = log(d1);
17130     food_(&d__1);
17131 // FFEINTRIN_impDLOG10 //
17132     d__1 = d_lg10(&d1);
17133     food_(&d__1);
17134 // FFEINTRIN_impDMAX1 //
17135     d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
17136     food_(&d__1);
17137 // FFEINTRIN_impDMIN1 //
17138     d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
17139     food_(&d__1);
17140 // FFEINTRIN_impDMOD //
17141     d__1 = d_mod(&d1, &d2);
17142     food_(&d__1);
17143 // FFEINTRIN_impDNINT //
17144     d__1 = d_nint(&d1);
17145     food_(&d__1);
17146 // FFEINTRIN_impDPROD //
17147     d__1 = (doublereal) r1 * r2;
17148     food_(&d__1);
17149 // FFEINTRIN_impDSIGN //
17150     d__1 = d_sign(&d1, &d2);
17151     food_(&d__1);
17152 // FFEINTRIN_impDSIN //
17153     d__1 = sin(d1);
17154     food_(&d__1);
17155 // FFEINTRIN_impDSINH //
17156     d__1 = sinh(d1);
17157     food_(&d__1);
17158 // FFEINTRIN_impDSQRT //
17159     d__1 = sqrt(d1);
17160     food_(&d__1);
17161 // FFEINTRIN_impDTAN //
17162     d__1 = tan(d1);
17163     food_(&d__1);
17164 // FFEINTRIN_impDTANH //
17165     d__1 = tanh(d1);
17166     food_(&d__1);
17167 // FFEINTRIN_impEXP //
17168     r__1 = exp(r1);
17169     foor_(&r__1);
17170 // FFEINTRIN_impIABS //
17171     i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
17172     fooi_(&i__1);
17173 // FFEINTRIN_impICHAR //
17174     i__1 = *(unsigned char *)a1;
17175     fooi_(&i__1);
17176 // FFEINTRIN_impIDIM //
17177     i__1 = i_dim(&i1, &i2);
17178     fooi_(&i__1);
17179 // FFEINTRIN_impIDNINT //
17180     i__1 = i_dnnt(&d1);
17181     fooi_(&i__1);
17182 // FFEINTRIN_impINDEX //
17183     i__1 = i_indx(a1, a2, 10L, 10L);
17184     fooi_(&i__1);
17185 // FFEINTRIN_impISIGN //
17186     i__1 = i_sign(&i1, &i2);
17187     fooi_(&i__1);
17188 // FFEINTRIN_impLEN //
17189     i__1 = i_len(a1, 10L);
17190     fooi_(&i__1);
17191 // FFEINTRIN_impLGE //
17192     L__1 = l_ge(a1, a2, 10L, 10L);
17193     fool_(&L__1);
17194 // FFEINTRIN_impLGT //
17195     L__1 = l_gt(a1, a2, 10L, 10L);
17196     fool_(&L__1);
17197 // FFEINTRIN_impLLE //
17198     L__1 = l_le(a1, a2, 10L, 10L);
17199     fool_(&L__1);
17200 // FFEINTRIN_impLLT //
17201     L__1 = l_lt(a1, a2, 10L, 10L);
17202     fool_(&L__1);
17203 // FFEINTRIN_impMAX0 //
17204     i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
17205     fooi_(&i__1);
17206 // FFEINTRIN_impMAX1 //
17207     i__1 = (integer) (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
17208     fooi_(&i__1);
17209 // FFEINTRIN_impMIN0 //
17210     i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
17211     fooi_(&i__1);
17212 // FFEINTRIN_impMIN1 //
17213     i__1 = (integer) (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
17214     fooi_(&i__1);
17215 // FFEINTRIN_impMOD //
17216     i__1 = i1 % i2;
17217     fooi_(&i__1);
17218 // FFEINTRIN_impNINT //
17219     i__1 = i_nint(&r1);
17220     fooi_(&i__1);
17221 // FFEINTRIN_impSIGN //
17222     r__1 = r_sign(&r1, &r2);
17223     foor_(&r__1);
17224 // FFEINTRIN_impSIN //
17225     r__1 = sin(r1);
17226     foor_(&r__1);
17227 // FFEINTRIN_impSINH //
17228     r__1 = sinh(r1);
17229     foor_(&r__1);
17230 // FFEINTRIN_impSQRT //
17231     r__1 = sqrt(r1);
17232     foor_(&r__1);
17233 // FFEINTRIN_impTAN //
17234     r__1 = tan(r1);
17235     foor_(&r__1);
17236 // FFEINTRIN_impTANH //
17237     r__1 = tanh(r1);
17238     foor_(&r__1);
17239 // FFEINTRIN_imp_CMPLX_C //
17240     r__1 = c1.r;
17241     r__2 = c2.r;
17242     q__1.r = r__1, q__1.i = r__2;
17243     fooc_(&q__1);
17244 // FFEINTRIN_imp_CMPLX_D //
17245     z__1.r = d1, z__1.i = d2;
17246     fooz_(&z__1);
17247 // FFEINTRIN_imp_CMPLX_I //
17248     r__1 = (real) i1;
17249     r__2 = (real) i2;
17250     q__1.r = r__1, q__1.i = r__2;
17251     fooc_(&q__1);
17252 // FFEINTRIN_imp_CMPLX_R //
17253     q__1.r = r1, q__1.i = r2;
17254     fooc_(&q__1);
17255 // FFEINTRIN_imp_DBLE_C //
17256     d__1 = (doublereal) c1.r;
17257     food_(&d__1);
17258 // FFEINTRIN_imp_DBLE_D //
17259     d__1 = d1;
17260     food_(&d__1);
17261 // FFEINTRIN_imp_DBLE_I //
17262     d__1 = (doublereal) i1;
17263     food_(&d__1);
17264 // FFEINTRIN_imp_DBLE_R //
17265     d__1 = (doublereal) r1;
17266     food_(&d__1);
17267 // FFEINTRIN_imp_INT_C //
17268     i__1 = (integer) c1.r;
17269     fooi_(&i__1);
17270 // FFEINTRIN_imp_INT_D //
17271     i__1 = (integer) d1;
17272     fooi_(&i__1);
17273 // FFEINTRIN_imp_INT_I //
17274     i__1 = i1;
17275     fooi_(&i__1);
17276 // FFEINTRIN_imp_INT_R //
17277     i__1 = (integer) r1;
17278     fooi_(&i__1);
17279 // FFEINTRIN_imp_REAL_C //
17280     r__1 = c1.r;
17281     foor_(&r__1);
17282 // FFEINTRIN_imp_REAL_D //
17283     r__1 = (real) d1;
17284     foor_(&r__1);
17285 // FFEINTRIN_imp_REAL_I //
17286     r__1 = (real) i1;
17287     foor_(&r__1);
17288 // FFEINTRIN_imp_REAL_R //
17289     r__1 = r1;
17290     foor_(&r__1);
17291
17292 // FFEINTRIN_imp_INT_D: //
17293
17294 // FFEINTRIN_specIDINT //
17295     i__1 = (integer) d1;
17296     fooi_(&i__1);
17297
17298 // FFEINTRIN_imp_INT_R: //
17299
17300 // FFEINTRIN_specIFIX //
17301     i__1 = (integer) r1;
17302     fooi_(&i__1);
17303 // FFEINTRIN_specINT //
17304     i__1 = (integer) r1;
17305     fooi_(&i__1);
17306
17307 // FFEINTRIN_imp_REAL_D: //
17308
17309 // FFEINTRIN_specSNGL //
17310     r__1 = (real) d1;
17311     foor_(&r__1);
17312
17313 // FFEINTRIN_imp_REAL_I: //
17314
17315 // FFEINTRIN_specFLOAT //
17316     r__1 = (real) i1;
17317     foor_(&r__1);
17318 // FFEINTRIN_specREAL //
17319     r__1 = (real) i1;
17320     foor_(&r__1);
17321
17322 } // MAIN__ //
17323
17324 -------- (end output file from f2c)
17325
17326 */