contrib/gcc/f/com.c

   1 /* com.c -- Implementation File (module.c template V1.0)
   2    Copyright (C) 1995-1998 Free Software Foundation, Inc.
   3    Contributed by James Craig Burley.
   4
   5 This file is part of GNU Fortran.
   6
   7 GNU Fortran is free software; you can redistribute it and/or modify
   8 it under the terms of the GNU General Public License as published by
   9 the Free Software Foundation; either version 2, or (at your option)
  10 any later version.
  11
  12 GNU Fortran is distributed in the hope that it will be useful,
  13 but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 GNU General Public License for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with GNU Fortran; see the file COPYING.  If not, write to
  19 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
  20 02111-1307, USA.
  21
  22    Related Modules:
  23       None
  24
  25    Description:
  26       Contains compiler-specific functions.
  27
  28    Modifications:
  29 */
  30
  31 /* Understanding this module means understanding the interface between
  32    the g77 front end and the gcc back end (or, perhaps, some other
  33    back end).  In here are the functions called by the front end proper
  34    to notify whatever back end is in place about certain things, and
  35    also the back-end-specific functions.  It's a bear to deal with, so
  36    lately I've been trying to simplify things, especially with regard
  37    to the gcc-back-end-specific stuff.
  38
  39    Building expressions generally seems quite easy, but building decls
  40    has been challenging and is undergoing revision.  gcc has several
  41    kinds of decls:
  42
  43    TYPE_DECL -- a type (int, float, struct, function, etc.)
  44    CONST_DECL -- a constant of some type other than function
  45    LABEL_DECL -- a variable or a constant?
  46    PARM_DECL -- an argument to a function (a variable that is a dummy)
  47    RESULT_DECL -- the return value of a function (a variable)
  48    VAR_DECL -- other variable (can hold a ptr-to-function, struct, int, etc.)
  49    FUNCTION_DECL -- a function (either the actual function or an extern ref)
  50    FIELD_DECL -- a field in a struct or union (goes into types)
  51
  52    g77 has a set of functions that somewhat parallels the gcc front end
  53    when it comes to building decls:
  54
  55    Internal Function (one we define, not just declare as extern):
  56    int yes;
  57    yes = suspend_momentary ();
  58    if (is_nested) push_f_function_context ();
  59    start_function (get_identifier ("function_name"), function_type,
  60                    is_nested, is_public);
  61    // for each arg, build PARM_DECL and call push_parm_decl (decl) with it;
  62    store_parm_decls (is_main_program);
  63    ffecom_start_compstmt ();
  64    // for stmts and decls inside function, do appropriate things;
  65    ffecom_end_compstmt ();
  66    finish_function (is_nested);
  67    if (is_nested) pop_f_function_context ();
  68    if (is_nested) resume_momentary (yes);
  69
  70    Everything Else:
  71    int yes;
  72    tree d;
  73    tree init;
  74    yes = suspend_momentary ();
  75    // fill in external, public, static, &c for decl, and
  76    // set DECL_INITIAL to error_mark_node if going to initialize
  77    // set is_top_level TRUE only if not at top level and decl
  78    // must go in top level (i.e. not within current function decl context)
  79    d = start_decl (decl, is_top_level);
  80    init = ...;  // if have initializer
  81    finish_decl (d, init, is_top_level);
  82    resume_momentary (yes);
  83
  84 */
  85
  86 /* Include files. */
  87
  88 #include "proj.h"
  89 #if FFECOM_targetCURRENT == FFECOM_targetGCC
  90 #include "flags.j"
  91 #include "rtl.j"
  92 #include "toplev.j"
  93 #include "tree.j"
  94 #include "output.j"  /* Must follow tree.j so TREE_CODE is defined! */
  95 #include "convert.j"
  96 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
  97
  98 #define FFECOM_GCC_INCLUDE 1    /* Enable -I. */
  99
 100 /* BEGIN stuff from gcc/cccp.c.  */
 101
 102 /* The following symbols should be autoconfigured:
 103         HAVE_FCNTL_H
 104         HAVE_STDLIB_H
 105         HAVE_SYS_TIME_H
 106         HAVE_UNISTD_H
 107         STDC_HEADERS
 108         TIME_WITH_SYS_TIME
 109    In the mean time, we'll get by with approximations based
 110    on existing GCC configuration symbols.  */
 111
 112 #ifdef POSIX
 113 # ifndef HAVE_STDLIB_H
 114 # define HAVE_STDLIB_H 1
 115 # endif
 116 # ifndef HAVE_UNISTD_H
 117 # define HAVE_UNISTD_H 1
 118 # endif
 119 # ifndef STDC_HEADERS
 120 # define STDC_HEADERS 1
 121 # endif
 122 #endif /* defined (POSIX) */
 123
 124 #if defined (POSIX) || (defined (USG) && !defined (VMS))
 125 # ifndef HAVE_FCNTL_H
 126 # define HAVE_FCNTL_H 1
 127 # endif
 128 #endif
 129
 130 #ifndef RLIMIT_STACK
 131 # include <time.h>
 132 #else
 133 # if TIME_WITH_SYS_TIME
 134 #  include <sys/time.h>
 135 #  include <time.h>
 136 # else
 137 #  if HAVE_SYS_TIME_H
 138 #   include <sys/time.h>
 139 #  else
 140 #   include <time.h>
 141 #  endif
 142 # endif
 143 # include <sys/resource.h>
 144 #endif
 145
 146 #if HAVE_FCNTL_H
 147 # include <fcntl.h>
 148 #endif
 149
 150 /* This defines "errno" properly for VMS, and gives us EACCES. */
 151 #include <errno.h>
 152
 153 #if HAVE_STDLIB_H
 154 # include <stdlib.h>
 155 #else
 156 char *getenv ();
 157 #endif
 158
 159 #if HAVE_UNISTD_H
 160 # include <unistd.h>
 161 #endif
 162
 163 /* VMS-specific definitions */
 164 #ifdef VMS
 165 #include <descrip.h>
 166 #define O_RDONLY        0       /* Open arg for Read/Only  */
 167 #define O_WRONLY        1       /* Open arg for Write/Only */
 168 #define read(fd,buf,size)       VMS_read (fd,buf,size)
 169 #define write(fd,buf,size)      VMS_write (fd,buf,size)
 170 #define open(fname,mode,prot)   VMS_open (fname,mode,prot)
 171 #define fopen(fname,mode)       VMS_fopen (fname,mode)
 172 #define freopen(fname,mode,ofile) VMS_freopen (fname,mode,ofile)
 173 #define strncat(dst,src,cnt) VMS_strncat (dst,src,cnt)
 174 #define fstat(fd,stbuf)         VMS_fstat (fd,stbuf)
 175 static int VMS_fstat (), VMS_stat ();
 176 static char * VMS_strncat ();
 177 static int VMS_read ();
 178 static int VMS_write ();
 179 static int VMS_open ();
 180 static FILE * VMS_fopen ();
 181 static FILE * VMS_freopen ();
 182 static void hack_vms_include_specification ();
 183 typedef struct { unsigned :16, :16, :16; } vms_ino_t;
 184 #define ino_t vms_ino_t
 185 #define INCLUDE_LEN_FUDGE 10    /* leave room for VMS syntax conversion */
 186 #ifdef __GNUC__
 187 #define BSTRING                 /* VMS/GCC supplies the bstring routines */
 188 #endif /* __GNUC__ */
 189 #endif /* VMS */
 190
 191 #ifndef O_RDONLY
 192 #define O_RDONLY 0
 193 #endif
 194
 195 /* END stuff from gcc/cccp.c.  */
 196
 197 #define FFECOM_DETERMINE_TYPES 1 /* for com.h */
 198 #include "com.h"
 199 #include "bad.h"
 200 #include "bld.h"
 201 #include "equiv.h"
 202 #include "expr.h"
 203 #include "implic.h"
 204 #include "info.h"
 205 #include "malloc.h"
 206 #include "src.h"
 207 #include "st.h"
 208 #include "storag.h"
 209 #include "symbol.h"
 210 #include "target.h"
 211 #include "top.h"
 212 #include "type.h"
 213
 214 /* Externals defined here.  */
 215
 216 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 217
 218 /* tree.h declares a bunch of stuff that it expects the front end to
 219    define.  Here are the definitions, which in the C front end are
 220    found in the file c-decl.c.  */
 221
 222 tree integer_zero_node;
 223 tree integer_one_node;
 224 tree null_pointer_node;
 225 tree error_mark_node;
 226 tree void_type_node;
 227 tree integer_type_node;
 228 tree unsigned_type_node;
 229 tree char_type_node;
 230 tree current_function_decl;
 231
 232 /* ~~gcc/tree.h *should* declare this, because toplev.c and dwarfout.c
 233    reference it.  */
 234
 235 char *language_string = "GNU F77";
 236
 237 /* Stream for reading from the input file.  */
 238 FILE *finput;
 239
 240 /* These definitions parallel those in c-decl.c so that code from that
 241    module can be used pretty much as is.  Much of these defs aren't
 242    otherwise used, i.e. by g77 code per se, except some of them are used
 243    to build some of them that are.  The ones that are global (i.e. not
 244    "static") are those that ste.c and such might use (directly
 245    or by using com macros that reference them in their definitions).  */
 246
 247 static tree short_integer_type_node;
 248 tree long_integer_type_node;
 249 static tree long_long_integer_type_node;
 250
 251 static tree short_unsigned_type_node;
 252 static tree long_unsigned_type_node;
 253 static tree long_long_unsigned_type_node;
 254
 255 static tree unsigned_char_type_node;
 256 static tree signed_char_type_node;
 257
 258 static tree float_type_node;
 259 static tree double_type_node;
 260 static tree complex_float_type_node;
 261 tree complex_double_type_node;
 262 static tree long_double_type_node;
 263 static tree complex_integer_type_node;
 264 static tree complex_long_double_type_node;
 265
 266 tree string_type_node;
 267
 268 static tree double_ftype_double;
 269 static tree float_ftype_float;
 270 static tree ldouble_ftype_ldouble;
 271
 272 /* The rest of these are inventions for g77, though there might be
 273    similar things in the C front end.  As they are found, these
 274    inventions should be renamed to be canonical.  Note that only
 275    the ones currently required to be global are so.  */
 276
 277 static tree ffecom_tree_fun_type_void;
 278 static tree ffecom_tree_ptr_to_fun_type_void;
 279
 280 tree ffecom_integer_type_node;  /* Abbrev for _tree_type[blah][blah]. */
 281 tree ffecom_integer_zero_node;  /* Like *_*_* with g77's integer type. */
 282 tree ffecom_integer_one_node;   /* " */
 283 tree ffecom_tree_type[FFEINFO_basictype][FFEINFO_kindtype];
 284
 285 /* _fun_type things are the f2c-specific versions.  For -fno-f2c,
 286    just use build_function_type and build_pointer_type on the
 287    appropriate _tree_type array element.  */
 288
 289 static tree ffecom_tree_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
 290 static tree ffecom_tree_ptr_to_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
 291 static tree ffecom_tree_subr_type;
 292 static tree ffecom_tree_ptr_to_subr_type;
 293 static tree ffecom_tree_blockdata_type;
 294
 295 static tree ffecom_tree_xargc_;
 296
 297 ffecomSymbol ffecom_symbol_null_
 298 =
 299 {
 300   NULL_TREE,
 301   NULL_TREE,
 302   NULL_TREE,
 303   NULL_TREE,
 304   false
 305 };
 306 ffeinfoKindtype ffecom_pointer_kind_ = FFEINFO_basictypeNONE;
 307 ffeinfoKindtype ffecom_label_kind_ = FFEINFO_basictypeNONE;
 308
 309 int ffecom_f2c_typecode_[FFEINFO_basictype][FFEINFO_kindtype];
 310 tree ffecom_f2c_integer_type_node;
 311 tree ffecom_f2c_ptr_to_integer_type_node;
 312 tree ffecom_f2c_address_type_node;
 313 tree ffecom_f2c_real_type_node;
 314 tree ffecom_f2c_ptr_to_real_type_node;
 315 tree ffecom_f2c_doublereal_type_node;
 316 tree ffecom_f2c_complex_type_node;
 317 tree ffecom_f2c_doublecomplex_type_node;
 318 tree ffecom_f2c_longint_type_node;
 319 tree ffecom_f2c_logical_type_node;
 320 tree ffecom_f2c_flag_type_node;
 321 tree ffecom_f2c_ftnlen_type_node;
 322 tree ffecom_f2c_ftnlen_zero_node;
 323 tree ffecom_f2c_ftnlen_one_node;
 324 tree ffecom_f2c_ftnlen_two_node;
 325 tree ffecom_f2c_ptr_to_ftnlen_type_node;
 326 tree ffecom_f2c_ftnint_type_node;
 327 tree ffecom_f2c_ptr_to_ftnint_type_node;
 328 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 329
 330 /* Simple definitions and enumerations. */
 331
 332 #ifndef FFECOM_sizeMAXSTACKITEM
 333 #define FFECOM_sizeMAXSTACKITEM 32*1024 /* Keep user-declared things
 334                                            larger than this # bytes
 335                                            off stack if possible. */
 336 #endif
 337
 338 /* For systems that have large enough stacks, they should define
 339    this to 0, and here, for ease of use later on, we just undefine
 340    it if it is 0.  */
 341
 342 #if FFECOM_sizeMAXSTACKITEM == 0
 343 #undef FFECOM_sizeMAXSTACKITEM
 344 #endif
 345
 346 typedef enum
 347   {
 348     FFECOM_rttypeVOID_,
 349     FFECOM_rttypeVOIDSTAR_,     /* C's `void *' type. */
 350     FFECOM_rttypeFTNINT_,       /* f2c's `ftnint' type. */
 351     FFECOM_rttypeINTEGER_,      /* f2c's `integer' type. */
 352     FFECOM_rttypeLONGINT_,      /* f2c's `longint' type. */
 353     FFECOM_rttypeLOGICAL_,      /* f2c's `logical' type. */
 354     FFECOM_rttypeREAL_F2C_,     /* f2c's `real' returned as `double'. */
 355     FFECOM_rttypeREAL_GNU_,     /* `real' returned as such. */
 356     FFECOM_rttypeCOMPLEX_F2C_,  /* f2c's `complex' returned via 1st arg. */
 357     FFECOM_rttypeCOMPLEX_GNU_,  /* f2c's `complex' returned directly. */
 358     FFECOM_rttypeDOUBLE_,       /* C's `double' type. */
 359     FFECOM_rttypeDOUBLEREAL_,   /* f2c's `doublereal' type. */
 360     FFECOM_rttypeDBLCMPLX_F2C_, /* f2c's `doublecomplex' returned via 1st arg. */
 361     FFECOM_rttypeDBLCMPLX_GNU_, /* f2c's `doublecomplex' returned directly. */
 362     FFECOM_rttypeCHARACTER_,    /* f2c `char *'/`ftnlen' pair. */
 363     FFECOM_rttype_
 364   } ffecomRttype_;
 365
 366 /* Internal typedefs. */
 367
 368 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 369 typedef struct _ffecom_concat_list_ ffecomConcatList_;
 370 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 371
 372 /* Private include files. */
 373
 374
 375 /* Internal structure definitions. */
 376
 377 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 378 struct _ffecom_concat_list_
 379   {
 380     ffebld *exprs;
 381     int count;
 382     int max;
 383     ffetargetCharacterSize minlen;
 384     ffetargetCharacterSize maxlen;
 385   };
 386 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 387
 388 /* Static functions (internal). */
 389
 390 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 391 static tree ffecom_arglist_expr_ (const char *argstring, ffebld args);
 392 static tree ffecom_widest_expr_type_ (ffebld list);
 393 static bool ffecom_overlap_ (tree dest_decl, tree dest_offset,
 394                              tree dest_size, tree source_tree,
 395                              ffebld source, bool scalar_arg);
 396 static bool ffecom_args_overlapping_ (tree dest_tree, ffebld dest,
 397                                       tree args, tree callee_commons,
 398                                       bool scalar_args);
 399 static tree ffecom_build_f2c_string_ (int i, const char *s);
 400 static tree ffecom_call_ (tree fn, ffeinfoKindtype kt,
 401                           bool is_f2c_complex, tree type,
 402                           tree args, tree dest_tree,
 403                           ffebld dest, bool *dest_used,
 404                           tree callee_commons, bool scalar_args, tree hook);
 405 static tree ffecom_call_binop_ (tree fn, ffeinfoKindtype kt,
 406                                 bool is_f2c_complex, tree type,
 407                                 ffebld left, ffebld right,
 408                                 tree dest_tree, ffebld dest,
 409                                 bool *dest_used, tree callee_commons,
 410                                 bool scalar_args, tree hook);
 411 static void ffecom_char_args_x_ (tree *xitem, tree *length,
 412                                  ffebld expr, bool with_null);
 413 static tree ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy);
 414 static tree ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s);
 415 static ffecomConcatList_
 416   ffecom_concat_list_gather_ (ffecomConcatList_ catlist,
 417                               ffebld expr,
 418                               ffetargetCharacterSize max);
 419 static void ffecom_concat_list_kill_ (ffecomConcatList_ catlist);
 420 static ffecomConcatList_ ffecom_concat_list_new_ (ffebld expr,
 421                                                 ffetargetCharacterSize max);
 422 static void ffecom_debug_kludge_ (tree aggr, const char *aggr_type,
 423                                   ffesymbol member, tree member_type,
 424                                   ffetargetOffset offset);
 425 static void ffecom_do_entry_ (ffesymbol fn, int entrynum);
 426 static tree ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
 427                           bool *dest_used, bool assignp, bool widenp);
 428 static tree ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
 429                                     ffebld dest, bool *dest_used);
 430 static tree ffecom_expr_power_integer_ (ffebld expr);
 431 static void ffecom_expr_transform_ (ffebld expr);
 432 static void ffecom_f2c_make_type_ (tree *type, int tcode, const char *name);
 433 static void ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
 434                                       int code);
 435 static ffeglobal ffecom_finish_global_ (ffeglobal global);
 436 static ffesymbol ffecom_finish_symbol_transform_ (ffesymbol s);
 437 static tree ffecom_get_appended_identifier_ (char us, const char *text);
 438 static tree ffecom_get_external_identifier_ (ffesymbol s);
 439 static tree ffecom_get_identifier_ (const char *text);
 440 static tree ffecom_gen_sfuncdef_ (ffesymbol s,
 441                                   ffeinfoBasictype bt,
 442                                   ffeinfoKindtype kt);
 443 static const char *ffecom_gfrt_args_ (ffecomGfrt ix);
 444 static tree ffecom_gfrt_tree_ (ffecomGfrt ix);
 445 static tree ffecom_init_zero_ (tree decl);
 446 static tree ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
 447                                      tree *maybe_tree);
 448 static tree ffecom_intrinsic_len_ (ffebld expr);
 449 static void ffecom_let_char_ (tree dest_tree,
 450                               tree dest_length,
 451                               ffetargetCharacterSize dest_size,
 452                               ffebld source);
 453 static void ffecom_make_gfrt_ (ffecomGfrt ix);
 454 static void ffecom_member_phase1_ (ffestorag mst, ffestorag st);
 455 #ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
 456 static void ffecom_member_phase2_ (ffestorag mst, ffestorag st);
 457 #endif
 458 static void ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size,
 459                                       ffebld source);
 460 static void ffecom_push_dummy_decls_ (ffebld dumlist,
 461                                       bool stmtfunc);
 462 static void ffecom_start_progunit_ (void);
 463 static ffesymbol ffecom_sym_transform_ (ffesymbol s);
 464 static ffesymbol ffecom_sym_transform_assign_ (ffesymbol s);
 465 static void ffecom_transform_common_ (ffesymbol s);
 466 static void ffecom_transform_equiv_ (ffestorag st);
 467 static tree ffecom_transform_namelist_ (ffesymbol s);
 468 static void ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
 469                                        tree t);
 470 static void ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
 471                                        tree *size, tree tree);
 472 static tree ffecom_tree_divide_ (tree tree_type, tree left, tree right,
 473                                  tree dest_tree, ffebld dest,
 474                                  bool *dest_used, tree hook);
 475 static tree ffecom_type_localvar_ (ffesymbol s,
 476                                    ffeinfoBasictype bt,
 477                                    ffeinfoKindtype kt);
 478 static tree ffecom_type_namelist_ (void);
 479 #if 0
 480 static tree ffecom_type_permanent_copy_ (tree t);
 481 #endif
 482 static tree ffecom_type_vardesc_ (void);
 483 static tree ffecom_vardesc_ (ffebld expr);
 484 static tree ffecom_vardesc_array_ (ffesymbol s);
 485 static tree ffecom_vardesc_dims_ (ffesymbol s);
 486 static tree ffecom_convert_narrow_ (tree type, tree expr);
 487 static tree ffecom_convert_widen_ (tree type, tree expr);
 488 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 489
 490 /* These are static functions that parallel those found in the C front
 491    end and thus have the same names.  */
 492
 493 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 494 static tree bison_rule_compstmt_ (void);
 495 static void bison_rule_pushlevel_ (void);
 496 static tree builtin_function (const char *name, tree type,
 497                               enum built_in_function function_code,
 498                               const char *library_name);
 499 static void delete_block (tree block);
 500 static int duplicate_decls (tree newdecl, tree olddecl);
 501 static void finish_decl (tree decl, tree init, bool is_top_level);
 502 static void finish_function (int nested);
 503 static char *lang_printable_name (tree decl, int v);
 504 static tree lookup_name_current_level (tree name);
 505 static struct binding_level *make_binding_level (void);
 506 static void pop_f_function_context (void);
 507 static void push_f_function_context (void);
 508 static void push_parm_decl (tree parm);
 509 static tree pushdecl_top_level (tree decl);
 510 static int kept_level_p (void);
 511 static tree storedecls (tree decls);
 512 static void store_parm_decls (int is_main_program);
 513 static tree start_decl (tree decl, bool is_top_level);
 514 static void start_function (tree name, tree type, int nested, int public);
 515 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 516 #if FFECOM_GCC_INCLUDE
 517 static void ffecom_file_ (char *name);
 518 static void ffecom_initialize_char_syntax_ (void);
 519 static void ffecom_close_include_ (FILE *f);
 520 static int ffecom_decode_include_option_ (char *spec);
 521 static FILE *ffecom_open_include_ (char *name, ffewhereLine l,
 522                                    ffewhereColumn c);
 523 #endif  /* FFECOM_GCC_INCLUDE */
 524
 525 /* Static objects accessed by functions in this module. */
 526
 527 static ffesymbol ffecom_primary_entry_ = NULL;
 528 static ffesymbol ffecom_nested_entry_ = NULL;
 529 static ffeinfoKind ffecom_primary_entry_kind_;
 530 static bool ffecom_primary_entry_is_proc_;
 531 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 532 static tree ffecom_outer_function_decl_;
 533 static tree ffecom_previous_function_decl_;
 534 static tree ffecom_which_entrypoint_decl_;
 535 static tree ffecom_float_zero_ = NULL_TREE;
 536 static tree ffecom_float_half_ = NULL_TREE;
 537 static tree ffecom_double_zero_ = NULL_TREE;
 538 static tree ffecom_double_half_ = NULL_TREE;
 539 static tree ffecom_func_result_;/* For functions. */
 540 static tree ffecom_func_length_;/* For CHARACTER fns. */
 541 static ffebld ffecom_list_blockdata_;
 542 static ffebld ffecom_list_common_;
 543 static ffebld ffecom_master_arglist_;
 544 static ffeinfoBasictype ffecom_master_bt_;
 545 static ffeinfoKindtype ffecom_master_kt_;
 546 static ffetargetCharacterSize ffecom_master_size_;
 547 static int ffecom_num_fns_ = 0;
 548 static int ffecom_num_entrypoints_ = 0;
 549 static bool ffecom_is_altreturning_ = FALSE;
 550 static tree ffecom_multi_type_node_;
 551 static tree ffecom_multi_retval_;
 552 static tree
 553   ffecom_multi_fields_[FFEINFO_basictype][FFEINFO_kindtype];
 554 static bool ffecom_member_namelisted_;  /* _member_phase1_ namelisted? */
 555 static bool ffecom_doing_entry_ = FALSE;
 556 static bool ffecom_transform_only_dummies_ = FALSE;
 557 static int ffecom_typesize_pointer_;
 558 static int ffecom_typesize_integer1_;
 559
 560 /* Holds pointer-to-function expressions.  */
 561
 562 static tree ffecom_gfrt_[FFECOM_gfrt]
 563 =
 564 {
 565 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) NULL_TREE,
 566 #include "com-rt.def"
 567 #undef DEFGFRT
 568 };
 569
 570 /* Holds the external names of the functions.  */
 571
 572 static const char *ffecom_gfrt_name_[FFECOM_gfrt]
 573 =
 574 {
 575 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) NAME,
 576 #include "com-rt.def"
 577 #undef DEFGFRT
 578 };
 579
 580 /* Whether the function returns.  */
 581
 582 static bool ffecom_gfrt_volatile_[FFECOM_gfrt]
 583 =
 584 {
 585 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) VOLATILE,
 586 #include "com-rt.def"
 587 #undef DEFGFRT
 588 };
 589
 590 /* Whether the function returns type complex.  */
 591
 592 static bool ffecom_gfrt_complex_[FFECOM_gfrt]
 593 =
 594 {
 595 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) COMPLEX,
 596 #include "com-rt.def"
 597 #undef DEFGFRT
 598 };
 599
 600 /* Type code for the function return value.  */
 601
 602 static ffecomRttype_ ffecom_gfrt_type_[FFECOM_gfrt]
 603 =
 604 {
 605 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) TYPE,
 606 #include "com-rt.def"
 607 #undef DEFGFRT
 608 };
 609
 610 /* String of codes for the function's arguments.  */
 611
 612 static const char *ffecom_gfrt_argstring_[FFECOM_gfrt]
 613 =
 614 {
 615 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) ARGS,
 616 #include "com-rt.def"
 617 #undef DEFGFRT
 618 };
 619 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 620
 621 /* Internal macros. */
 622
 623 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 624
 625 /* We let tm.h override the types used here, to handle trivial differences
 626    such as the choice of unsigned int or long unsigned int for size_t.
 627    When machines start needing nontrivial differences in the size type,
 628    it would be best to do something here to figure out automatically
 629    from other information what type to use.  */
 630
 631 #ifndef SIZE_TYPE
 632 #define SIZE_TYPE "long unsigned int"
 633 #endif
 634
 635 #define ffecom_concat_list_count_(catlist) ((catlist).count)
 636 #define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)])
 637 #define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen)
 638 #define ffecom_concat_list_minlen_(catlist) ((catlist).minlen)
 639
 640 #define ffecom_char_args_(i,l,e) ffecom_char_args_x_((i),(l),(e),FALSE)
 641 #define ffecom_char_args_with_null_(i,l,e) ffecom_char_args_x_((i),(l),(e),TRUE)
 642
 643 /* For each binding contour we allocate a binding_level structure
 644  * which records the names defined in that contour.
 645  * Contours include:
 646  *  0) the global one
 647  *  1) one for each function definition,
 648  *     where internal declarations of the parameters appear.
 649  *
 650  * The current meaning of a name can be found by searching the levels from
 651  * the current one out to the global one.
 652  */
 653
 654 /* Note that the information in the `names' component of the global contour
 655    is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers.  */
 656
 657 struct binding_level
 658   {
 659     /* A chain of _DECL nodes for all variables, constants, functions,
 660        and typedef types.  These are in the reverse of the order supplied.
 661      */
 662     tree names;
 663
 664     /* For each level (except not the global one),
 665        a chain of BLOCK nodes for all the levels
 666        that were entered and exited one level down.  */
 667     tree blocks;
 668
 669     /* The BLOCK node for this level, if one has been preallocated.
 670        If 0, the BLOCK is allocated (if needed) when the level is popped.  */
 671     tree this_block;
 672
 673     /* The binding level which this one is contained in (inherits from).  */
 674     struct binding_level *level_chain;
 675
 676     /* 0: no ffecom_prepare_* functions called at this level yet;
 677        1: ffecom_prepare* functions called, except not ffecom_prepare_end;
 678        2: ffecom_prepare_end called.  */
 679     int prep_state;
 680   };
 681
 682 #define NULL_BINDING_LEVEL (struct binding_level *) NULL
 683
 684 /* The binding level currently in effect.  */
 685
 686 static struct binding_level *current_binding_level;
 687
 688 /* A chain of binding_level structures awaiting reuse.  */
 689
 690 static struct binding_level *free_binding_level;
 691
 692 /* The outermost binding level, for names of file scope.
 693    This is created when the compiler is started and exists
 694    through the entire run.  */
 695
 696 static struct binding_level *global_binding_level;
 697
 698 /* Binding level structures are initialized by copying this one.  */
 699
 700 static struct binding_level clear_binding_level
 701 =
 702 {NULL, NULL, NULL, NULL_BINDING_LEVEL, 0};
 703
 704 /* Language-dependent contents of an identifier.  */
 705
 706 struct lang_identifier
 707   {
 708     struct tree_identifier ignore;
 709     tree global_value, local_value, label_value;
 710     bool invented;
 711   };
 712
 713 /* Macros for access to language-specific slots in an identifier.  */
 714 /* Each of these slots contains a DECL node or null.  */
 715
 716 /* This represents the value which the identifier has in the
 717    file-scope namespace.  */
 718 #define IDENTIFIER_GLOBAL_VALUE(NODE)   \
 719   (((struct lang_identifier *)(NODE))->global_value)
 720 /* This represents the value which the identifier has in the current
 721    scope.  */
 722 #define IDENTIFIER_LOCAL_VALUE(NODE)    \
 723   (((struct lang_identifier *)(NODE))->local_value)
 724 /* This represents the value which the identifier has as a label in
 725    the current label scope.  */
 726 #define IDENTIFIER_LABEL_VALUE(NODE)    \
 727   (((struct lang_identifier *)(NODE))->label_value)
 728 /* This is nonzero if the identifier was "made up" by g77 code.  */
 729 #define IDENTIFIER_INVENTED(NODE)       \
 730   (((struct lang_identifier *)(NODE))->invented)
 731
 732 /* In identifiers, C uses the following fields in a special way:
 733    TREE_PUBLIC        to record that there was a previous local extern decl.
 734    TREE_USED          to record that such a decl was used.
 735    TREE_ADDRESSABLE   to record that the address of such a decl was used.  */
 736
 737 /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
 738    that have names.  Here so we can clear out their names' definitions
 739    at the end of the function.  */
 740
 741 static tree named_labels;
 742
 743 /* A list of LABEL_DECLs from outer contexts that are currently shadowed.  */
 744
 745 static tree shadowed_labels;
 746
 747 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 748 \f
 749 /* Return the subscript expression, modified to do range-checking.
 750
 751    `array' is the array to be checked against.
 752    `element' is the subscript expression to check.
 753    `dim' is the dimension number (starting at 0).
 754    `total_dims' is the total number of dimensions (0 for CHARACTER substring).
 755 */
 756
 757 static tree
 758 ffecom_subscript_check_ (tree array, tree element, int dim, int total_dims,
 759                          char *array_name)
 760 {
 761   tree low = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 762   tree high = TYPE_MAX_VALUE (TYPE_DOMAIN (array));
 763   tree cond;
 764   tree die;
 765   tree args;
 766
 767   if (element == error_mark_node)
 768     return element;
 769
 770   if (TREE_TYPE (low) != TREE_TYPE (element))
 771     {
 772       if (TYPE_PRECISION (TREE_TYPE (low))
 773           > TYPE_PRECISION (TREE_TYPE (element)))
 774         element = convert (TREE_TYPE (low), element);
 775       else
 776         {
 777           low = convert (TREE_TYPE (element), low);
 778           if (high)
 779             high = convert (TREE_TYPE (element), high);
 780         }
 781     }
 782
 783   element = ffecom_save_tree (element);
 784   cond = ffecom_2 (LE_EXPR, integer_type_node,
 785                    low,
 786                    element);
 787   if (high)
 788     {
 789       cond = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
 790                        cond,
 791                        ffecom_2 (LE_EXPR, integer_type_node,
 792                                  element,
 793                                  high));
 794     }
 795
 796   {
 797     int len;
 798     char *proc;
 799     char *var;
 800     tree arg3;
 801     tree arg2;
 802     tree arg1;
 803     tree arg4;
 804
 805     switch (total_dims)
 806       {
 807       case 0:
 808         var = xmalloc (strlen (array_name) + 20);
 809         sprintf (&var[0], "%s[%s-substring]",
 810                  array_name,
 811                  dim ? "end" : "start");
 812         len = strlen (var) + 1;
 813         break;
 814
 815       case 1:
 816         len = strlen (array_name) + 1;
 817         var = array_name;
 818         break;
 819
 820       default:
 821         var = xmalloc (strlen (array_name) + 40);
 822         sprintf (&var[0], "%s[subscript-%d-of-%d]",
 823                  array_name,
 824                  dim + 1, total_dims);
 825         len = strlen (var) + 1;
 826         break;
 827       }
 828
 829     arg1 = build_string (len, var);
 830
 831     if (total_dims != 1)
 832       free (var);
 833
 834     TREE_TYPE (arg1)
 835       = build_type_variant (build_array_type (char_type_node,
 836                                               build_range_type
 837                                               (integer_type_node,
 838                                                integer_one_node,
 839                                                build_int_2 (len, 0))),
 840                             1, 0);
 841     TREE_CONSTANT (arg1) = 1;
 842     TREE_STATIC (arg1) = 1;
 843     arg1 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg1)),
 844                      arg1);
 845
 846     /* s_rnge adds one to the element to print it, so bias against
 847        that -- want to print a faithful *subscript* value.  */
 848     arg2 = convert (ffecom_f2c_ftnint_type_node,
 849                     ffecom_2 (MINUS_EXPR,
 850                               TREE_TYPE (element),
 851                               element,
 852                               convert (TREE_TYPE (element),
 853                                        integer_one_node)));
 854
 855     proc = xmalloc ((len = strlen (input_filename)
 856                      + IDENTIFIER_LENGTH (DECL_NAME (current_function_decl))
 857                      + 2));
 858
 859     sprintf (&proc[0], "%s/%s",
 860              input_filename,
 861              IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
 862     arg3 = build_string (len, proc);
 863
 864     free (proc);
 865
 866     TREE_TYPE (arg3)
 867       = build_type_variant (build_array_type (char_type_node,
 868                                               build_range_type
 869                                               (integer_type_node,
 870                                                integer_one_node,
 871                                                build_int_2 (len, 0))),
 872                             1, 0);
 873     TREE_CONSTANT (arg3) = 1;
 874     TREE_STATIC (arg3) = 1;
 875     arg3 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg3)),
 876                      arg3);
 877
 878     arg4 = convert (ffecom_f2c_ftnint_type_node,
 879                     build_int_2 (lineno, 0));
 880
 881     arg1 = build_tree_list (NULL_TREE, arg1);
 882     arg2 = build_tree_list (NULL_TREE, arg2);
 883     arg3 = build_tree_list (NULL_TREE, arg3);
 884     arg4 = build_tree_list (NULL_TREE, arg4);
 885     TREE_CHAIN (arg3) = arg4;
 886     TREE_CHAIN (arg2) = arg3;
 887     TREE_CHAIN (arg1) = arg2;
 888
 889     args = arg1;
 890   }
 891   die = ffecom_call_gfrt (FFECOM_gfrtRANGE,
 892                           args, NULL_TREE);
 893   TREE_SIDE_EFFECTS (die) = 1;
 894
 895   element = ffecom_3 (COND_EXPR,
 896                       TREE_TYPE (element),
 897                       cond,
 898                       element,
 899                       die);
 900
 901   return element;
 902 }
 903
 904 /* Return the computed element of an array reference.
 905
 906    `item' is NULL_TREE, or the transformed pointer to the array.
 907    `expr' is the original opARRAYREF expression, which is transformed
 908      if `item' is NULL_TREE.
 909    `want_ptr' is non-zero if a pointer to the element, instead of
 910      the element itself, is to be returned.  */
 911
 912 static tree
 913 ffecom_arrayref_ (tree item, ffebld expr, int want_ptr)
 914 {
 915   ffebld dims[FFECOM_dimensionsMAX];
 916   int i;
 917   int total_dims;
 918   int flatten = ffe_is_flatten_arrays ();
 919   int need_ptr;
 920   tree array;
 921   tree element;
 922   tree tree_type;
 923   tree tree_type_x;
 924   char *array_name;
 925   ffetype type;
 926   ffebld list;
 927
 928   if (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER)
 929     array_name = ffesymbol_text (ffebld_symter (ffebld_left (expr)));
 930   else
 931     array_name = "[expr?]";
 932
 933   /* Build up ARRAY_REFs in reverse order (since we're column major
 934      here in Fortran land). */
 935
 936   for (i = 0, list = ffebld_right (expr);
 937        list != NULL;
 938        ++i, list = ffebld_trail (list))
 939     {
 940       dims[i] = ffebld_head (list);
 941       type = ffeinfo_type (ffebld_basictype (dims[i]),
 942                            ffebld_kindtype (dims[i]));
 943       if (! flatten
 944           && ffecom_typesize_pointer_ > ffecom_typesize_integer1_
 945           && ffetype_size (type) > ffecom_typesize_integer1_)
 946         /* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit
 947            pointers and 32-bit integers.  Do the full 64-bit pointer
 948            arithmetic, for codes using arrays for nonstandard heap-like
 949            work.  */
 950         flatten = 1;
 951     }
 952
 953   total_dims = i;
 954
 955   need_ptr = want_ptr || flatten;
 956
 957   if (! item)
 958     {
 959       if (need_ptr)
 960         item = ffecom_ptr_to_expr (ffebld_left (expr));
 961       else
 962         item = ffecom_expr (ffebld_left (expr));
 963
 964       if (item == error_mark_node)
 965         return item;
 966
 967       if (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING
 968           && ! mark_addressable (item))
 969         return error_mark_node;
 970     }
 971
 972   if (item == error_mark_node)
 973     return item;
 974
 975   if (need_ptr)
 976     {
 977       tree min;
 978
 979       for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
 980            i >= 0;
 981            --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
 982         {
 983           min = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 984           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 985           if (ffe_is_subscript_check ())
 986             element = ffecom_subscript_check_ (array, element, i, total_dims,
 987                                                array_name);
 988           if (element == error_mark_node)
 989             return element;
 990
 991           /* Widen integral arithmetic as desired while preserving
 992              signedness.  */
 993           tree_type = TREE_TYPE (element);
 994           tree_type_x = tree_type;
 995           if (tree_type
 996               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
 997               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
 998             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
 999
1000           if (TREE_TYPE (min) != tree_type_x)
1001             min = convert (tree_type_x, min);
1002           if (TREE_TYPE (element) != tree_type_x)
1003             element = convert (tree_type_x, element);
1004
1005           item = ffecom_2 (PLUS_EXPR,
1006                            build_pointer_type (TREE_TYPE (array)),
1007                            item,
1008                            size_binop (MULT_EXPR,
1009                                        size_in_bytes (TREE_TYPE (array)),
1010                                        fold (build (MINUS_EXPR,
1011                                                     tree_type_x,
1012                                                     element,
1013                                                     min))));
1014         }
1015       if (! want_ptr)
1016         {
1017           item = ffecom_1 (INDIRECT_REF,
1018                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
1019                            item);
1020         }
1021     }
1022   else
1023     {
1024       for (--i;
1025            i >= 0;
1026            --i)
1027         {
1028           array = TYPE_MAIN_VARIANT (TREE_TYPE (item));
1029
1030           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
1031           if (ffe_is_subscript_check ())
1032             element = ffecom_subscript_check_ (array, element, i, total_dims,
1033                                                array_name);
1034           if (element == error_mark_node)
1035             return element;
1036
1037           /* Widen integral arithmetic as desired while preserving
1038              signedness.  */
1039           tree_type = TREE_TYPE (element);
1040           tree_type_x = tree_type;
1041           if (tree_type
1042               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
1043               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
1044             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
1045
1046           element = convert (tree_type_x, element);
1047
1048           item = ffecom_2 (ARRAY_REF,
1049                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
1050                            item,
1051                            element);
1052         }
1053     }
1054
1055   return item;
1056 }
1057
1058 /* This is like gcc's stabilize_reference -- in fact, most of the code
1059    comes from that -- but it handles the situation where the reference
1060    is going to have its subparts picked at, and it shouldn't change
1061    (or trigger extra invocations of functions in the subtrees) due to
1062    this.  save_expr is a bit overzealous, because we don't need the
1063    entire thing calculated and saved like a temp.  So, for DECLs, no
1064    change is needed, because these are stable aggregates, and ARRAY_REF
1065    and such might well be stable too, but for things like calculations,
1066    we do need to calculate a snapshot of a value before picking at it.  */
1067
1068 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1069 static tree
1070 ffecom_stabilize_aggregate_ (tree ref)
1071 {
1072   tree result;
1073   enum tree_code code = TREE_CODE (ref);
1074
1075   switch (code)
1076     {
1077     case VAR_DECL:
1078     case PARM_DECL:
1079     case RESULT_DECL:
1080       /* No action is needed in this case.  */
1081       return ref;
1082
1083     case NOP_EXPR:
1084     case CONVERT_EXPR:
1085     case FLOAT_EXPR:
1086     case FIX_TRUNC_EXPR:
1087     case FIX_FLOOR_EXPR:
1088     case FIX_ROUND_EXPR:
1089     case FIX_CEIL_EXPR:
1090       result = build_nt (code, stabilize_reference (TREE_OPERAND (ref, 0)));
1091       break;
1092
1093     case INDIRECT_REF:
1094       result = build_nt (INDIRECT_REF,
1095                          stabilize_reference_1 (TREE_OPERAND (ref, 0)));
1096       break;
1097
1098     case COMPONENT_REF:
1099       result = build_nt (COMPONENT_REF,
1100                          stabilize_reference (TREE_OPERAND (ref, 0)),
1101                          TREE_OPERAND (ref, 1));
1102       break;
1103
1104     case BIT_FIELD_REF:
1105       result = build_nt (BIT_FIELD_REF,
1106                          stabilize_reference (TREE_OPERAND (ref, 0)),
1107                          stabilize_reference_1 (TREE_OPERAND (ref, 1)),
1108                          stabilize_reference_1 (TREE_OPERAND (ref, 2)));
1109       break;
1110
1111     case ARRAY_REF:
1112       result = build_nt (ARRAY_REF,
1113                          stabilize_reference (TREE_OPERAND (ref, 0)),
1114                          stabilize_reference_1 (TREE_OPERAND (ref, 1)));
1115       break;
1116
1117     case COMPOUND_EXPR:
1118       result = build_nt (COMPOUND_EXPR,
1119                          stabilize_reference_1 (TREE_OPERAND (ref, 0)),
1120                          stabilize_reference (TREE_OPERAND (ref, 1)));
1121       break;
1122
1123     case RTL_EXPR:
1124       result = build1 (INDIRECT_REF, TREE_TYPE (ref),
1125                        save_expr (build1 (ADDR_EXPR,
1126                                           build_pointer_type (TREE_TYPE (ref)),
1127                                           ref)));
1128       break;
1129
1130
1131     default:
1132       return save_expr (ref);
1133
1134     case ERROR_MARK:
1135       return error_mark_node;
1136     }
1137
1138   TREE_TYPE (result) = TREE_TYPE (ref);
1139   TREE_READONLY (result) = TREE_READONLY (ref);
1140   TREE_SIDE_EFFECTS (result) = TREE_SIDE_EFFECTS (ref);
1141   TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
1142   TREE_RAISES (result) = TREE_RAISES (ref);
1143
1144   return result;
1145 }
1146 #endif
1147
1148 /* A rip-off of gcc's convert.c convert_to_complex function,
1149    reworked to handle complex implemented as C structures
1150    (RECORD_TYPE with two fields, real and imaginary `r' and `i').  */
1151
1152 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1153 static tree
1154 ffecom_convert_to_complex_ (tree type, tree expr)
1155 {
1156   register enum tree_code form = TREE_CODE (TREE_TYPE (expr));
1157   tree subtype;
1158
1159   assert (TREE_CODE (type) == RECORD_TYPE);
1160
1161   subtype = TREE_TYPE (TYPE_FIELDS (type));
1162
1163   if (form == REAL_TYPE || form == INTEGER_TYPE || form == ENUMERAL_TYPE)
1164     {
1165       expr = convert (subtype, expr);
1166       return ffecom_2 (COMPLEX_EXPR, type, expr,
1167                        convert (subtype, integer_zero_node));
1168     }
1169
1170   if (form == RECORD_TYPE)
1171     {
1172       tree elt_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr)));
1173       if (TYPE_MAIN_VARIANT (elt_type) == TYPE_MAIN_VARIANT (subtype))
1174         return expr;
1175       else
1176         {
1177           expr = save_expr (expr);
1178           return ffecom_2 (COMPLEX_EXPR,
1179                            type,
1180                            convert (subtype,
1181                                     ffecom_1 (REALPART_EXPR,
1182                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1183                                               expr)),
1184                            convert (subtype,
1185                                     ffecom_1 (IMAGPART_EXPR,
1186                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1187                                               expr)));
1188         }
1189     }
1190
1191   if (form == POINTER_TYPE || form == REFERENCE_TYPE)
1192     error ("pointer value used where a complex was expected");
1193   else
1194     error ("aggregate value used where a complex was expected");
1195
1196   return ffecom_2 (COMPLEX_EXPR, type,
1197                    convert (subtype, integer_zero_node),
1198                    convert (subtype, integer_zero_node));
1199 }
1200 #endif
1201
1202 /* Like gcc's convert(), but crashes if widening might happen.  */
1203
1204 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1205 static tree
1206 ffecom_convert_narrow_ (type, expr)
1207      tree type, expr;
1208 {
1209   register tree e = expr;
1210   register enum tree_code code = TREE_CODE (type);
1211
1212   if (type == TREE_TYPE (e)
1213       || TREE_CODE (e) == ERROR_MARK)
1214     return e;
1215   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1216     return fold (build1 (NOP_EXPR, type, e));
1217   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1218       || code == ERROR_MARK)
1219     return error_mark_node;
1220   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1221     {
1222       assert ("void value not ignored as it ought to be" == NULL);
1223       return error_mark_node;
1224     }
1225   assert (code != VOID_TYPE);
1226   if ((code != RECORD_TYPE)
1227       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1228     assert ("converting COMPLEX to REAL" == NULL);
1229   assert (code != ENUMERAL_TYPE);
1230   if (code == INTEGER_TYPE)
1231     {
1232       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1233                && TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)))
1234               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1235                   && (TYPE_PRECISION (type)
1236                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1237       return fold (convert_to_integer (type, e));
1238     }
1239   if (code == POINTER_TYPE)
1240     {
1241       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1242       return fold (convert_to_pointer (type, e));
1243     }
1244   if (code == REAL_TYPE)
1245     {
1246       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1247       assert (TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)));
1248       return fold (convert_to_real (type, e));
1249     }
1250   if (code == COMPLEX_TYPE)
1251     {
1252       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1253       assert (TYPE_PRECISION (TREE_TYPE (type)) <= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1254       return fold (convert_to_complex (type, e));
1255     }
1256   if (code == RECORD_TYPE)
1257     {
1258       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1259       /* Check that at least the first field name agrees.  */
1260       assert (DECL_NAME (TYPE_FIELDS (type))
1261               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1262       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1263               <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1264       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1265           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1266         return e;
1267       return fold (ffecom_convert_to_complex_ (type, e));
1268     }
1269
1270   assert ("conversion to non-scalar type requested" == NULL);
1271   return error_mark_node;
1272 }
1273 #endif
1274
1275 /* Like gcc's convert(), but crashes if narrowing might happen.  */
1276
1277 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1278 static tree
1279 ffecom_convert_widen_ (type, expr)
1280      tree type, expr;
1281 {
1282   register tree e = expr;
1283   register enum tree_code code = TREE_CODE (type);
1284
1285   if (type == TREE_TYPE (e)
1286       || TREE_CODE (e) == ERROR_MARK)
1287     return e;
1288   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1289     return fold (build1 (NOP_EXPR, type, e));
1290   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1291       || code == ERROR_MARK)
1292     return error_mark_node;
1293   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1294     {
1295       assert ("void value not ignored as it ought to be" == NULL);
1296       return error_mark_node;
1297     }
1298   assert (code != VOID_TYPE);
1299   if ((code != RECORD_TYPE)
1300       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1301     assert ("narrowing COMPLEX to REAL" == NULL);
1302   assert (code != ENUMERAL_TYPE);
1303   if (code == INTEGER_TYPE)
1304     {
1305       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1306                && TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)))
1307               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1308                   && (TYPE_PRECISION (type)
1309                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1310       return fold (convert_to_integer (type, e));
1311     }
1312   if (code == POINTER_TYPE)
1313     {
1314       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1315       return fold (convert_to_pointer (type, e));
1316     }
1317   if (code == REAL_TYPE)
1318     {
1319       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1320       assert (TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)));
1321       return fold (convert_to_real (type, e));
1322     }
1323   if (code == COMPLEX_TYPE)
1324     {
1325       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1326       assert (TYPE_PRECISION (TREE_TYPE (type)) >= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1327       return fold (convert_to_complex (type, e));
1328     }
1329   if (code == RECORD_TYPE)
1330     {
1331       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1332       /* Check that at least the first field name agrees.  */
1333       assert (DECL_NAME (TYPE_FIELDS (type))
1334               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1335       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1336               >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1337       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1338           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1339         return e;
1340       return fold (ffecom_convert_to_complex_ (type, e));
1341     }
1342
1343   assert ("conversion to non-scalar type requested" == NULL);
1344   return error_mark_node;
1345 }
1346 #endif
1347
1348 /* Handles making a COMPLEX type, either the standard
1349    (but buggy?) gbe way, or the safer (but less elegant?)
1350    f2c way.  */
1351
1352 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1353 static tree
1354 ffecom_make_complex_type_ (tree subtype)
1355 {
1356   tree type;
1357   tree realfield;
1358   tree imagfield;
1359
1360   if (ffe_is_emulate_complex ())
1361     {
1362       type = make_node (RECORD_TYPE);
1363       realfield = ffecom_decl_field (type, NULL_TREE, "r", subtype);
1364       imagfield = ffecom_decl_field (type, realfield, "i", subtype);
1365       TYPE_FIELDS (type) = realfield;
1366       layout_type (type);
1367     }
1368   else
1369     {
1370       type = make_node (COMPLEX_TYPE);
1371       TREE_TYPE (type) = subtype;
1372       layout_type (type);
1373     }
1374
1375   return type;
1376 }
1377 #endif
1378
1379 /* Chooses either the gbe or the f2c way to build a
1380    complex constant.  */
1381
1382 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1383 static tree
1384 ffecom_build_complex_constant_ (tree type, tree realpart, tree imagpart)
1385 {
1386   tree bothparts;
1387
1388   if (ffe_is_emulate_complex ())
1389     {
1390       bothparts = build_tree_list (TYPE_FIELDS (type), realpart);
1391       TREE_CHAIN (bothparts) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), imagpart);
1392       bothparts = build (CONSTRUCTOR, type, NULL_TREE, bothparts);
1393     }
1394   else
1395     {
1396       bothparts = build_complex (type, realpart, imagpart);
1397     }
1398
1399   return bothparts;
1400 }
1401 #endif
1402
1403 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1404 static tree
1405 ffecom_arglist_expr_ (const char *c, ffebld expr)
1406 {
1407   tree list;
1408   tree *plist = &list;
1409   tree trail = NULL_TREE;       /* Append char length args here. */
1410   tree *ptrail = &trail;
1411   tree length;
1412   ffebld exprh;
1413   tree item;
1414   bool ptr = FALSE;
1415   tree wanted = NULL_TREE;
1416   static char zed[] = "0";
1417
1418   if (c == NULL)
1419     c = &zed[0];
1420
1421   while (expr != NULL)
1422     {
1423       if (*c != '\0')
1424         {
1425           ptr = FALSE;
1426           if (*c == '&')
1427             {
1428               ptr = TRUE;
1429               ++c;
1430             }
1431           switch (*(c++))
1432             {
1433             case '\0':
1434               ptr = TRUE;
1435               wanted = NULL_TREE;
1436               break;
1437
1438             case 'a':
1439               assert (ptr);
1440               wanted = NULL_TREE;
1441               break;
1442
1443             case 'c':
1444               wanted = ffecom_f2c_complex_type_node;
1445               break;
1446
1447             case 'd':
1448               wanted = ffecom_f2c_doublereal_type_node;
1449               break;
1450
1451             case 'e':
1452               wanted = ffecom_f2c_doublecomplex_type_node;
1453               break;
1454
1455             case 'f':
1456               wanted = ffecom_f2c_real_type_node;
1457               break;
1458
1459             case 'i':
1460               wanted = ffecom_f2c_integer_type_node;
1461               break;
1462
1463             case 'j':
1464               wanted = ffecom_f2c_longint_type_node;
1465               break;
1466
1467             default:
1468               assert ("bad argstring code" == NULL);
1469               wanted = NULL_TREE;
1470               break;
1471             }
1472         }
1473
1474       exprh = ffebld_head (expr);
1475       if (exprh == NULL)
1476         wanted = NULL_TREE;
1477
1478       if ((wanted == NULL_TREE)
1479           || (ptr
1480               && (TYPE_MODE
1481                   (ffecom_tree_type[ffeinfo_basictype (ffebld_info (exprh))]
1482                    [ffeinfo_kindtype (ffebld_info (exprh))])
1483                    == TYPE_MODE (wanted))))
1484         *plist
1485           = build_tree_list (NULL_TREE,
1486                              ffecom_arg_ptr_to_expr (exprh,
1487                                                      &length));
1488       else
1489         {
1490           item = ffecom_arg_expr (exprh, &length);
1491           item = ffecom_convert_widen_ (wanted, item);
1492           if (ptr)
1493             {
1494               item = ffecom_1 (ADDR_EXPR,
1495                                build_pointer_type (TREE_TYPE (item)),
1496                                item);
1497             }
1498           *plist
1499             = build_tree_list (NULL_TREE,
1500                                item);
1501         }
1502
1503       plist = &TREE_CHAIN (*plist);
1504       expr = ffebld_trail (expr);
1505       if (length != NULL_TREE)
1506         {
1507           *ptrail = build_tree_list (NULL_TREE, length);
1508           ptrail = &TREE_CHAIN (*ptrail);
1509         }
1510     }
1511
1512   /* We've run out of args in the call; if the implementation expects
1513      more, supply null pointers for them, which the implementation can
1514      check to see if an arg was omitted. */
1515
1516   while (*c != '\0' && *c != '0')
1517     {
1518       if (*c == '&')
1519         ++c;
1520       else
1521         assert ("missing arg to run-time routine!" == NULL);
1522
1523       switch (*(c++))
1524         {
1525         case '\0':
1526         case 'a':
1527         case 'c':
1528         case 'd':
1529         case 'e':
1530         case 'f':
1531         case 'i':
1532         case 'j':
1533           break;
1534
1535         default:
1536           assert ("bad arg string code" == NULL);
1537           break;
1538         }
1539       *plist
1540         = build_tree_list (NULL_TREE,
1541                            null_pointer_node);
1542       plist = &TREE_CHAIN (*plist);
1543     }
1544
1545   *plist = trail;
1546
1547   return list;
1548 }
1549 #endif
1550
1551 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1552 static tree
1553 ffecom_widest_expr_type_ (ffebld list)
1554 {
1555   ffebld item;
1556   ffebld widest = NULL;
1557   ffetype type;
1558   ffetype widest_type = NULL;
1559   tree t;
1560
1561   for (; list != NULL; list = ffebld_trail (list))
1562     {
1563       item = ffebld_head (list);
1564       if (item == NULL)
1565         continue;
1566       if ((widest != NULL)
1567           && (ffeinfo_basictype (ffebld_info (item))
1568               != ffeinfo_basictype (ffebld_info (widest))))
1569         continue;
1570       type = ffeinfo_type (ffeinfo_basictype (ffebld_info (item)),
1571                            ffeinfo_kindtype (ffebld_info (item)));
1572       if ((widest == FFEINFO_kindtypeNONE)
1573           || (ffetype_size (type)
1574               > ffetype_size (widest_type)))
1575         {
1576           widest = item;
1577           widest_type = type;
1578         }
1579     }
1580
1581   assert (widest != NULL);
1582   t = ffecom_tree_type[ffeinfo_basictype (ffebld_info (widest))]
1583     [ffeinfo_kindtype (ffebld_info (widest))];
1584   assert (t != NULL_TREE);
1585   return t;
1586 }
1587 #endif
1588
1589 /* Check whether a partial overlap between two expressions is possible.
1590
1591    Can *starting* to write a portion of expr1 change the value
1592    computed (perhaps already, *partially*) by expr2?
1593
1594    Currently, this is a concern only for a COMPLEX expr1.  But if it
1595    isn't in COMMON or local EQUIVALENCE, since we don't support
1596    aliasing of arguments, it isn't a concern.  */
1597
1598 static bool
1599 ffecom_possible_partial_overlap_ (ffebld expr1, ffebld expr2)
1600 {
1601   ffesymbol sym;
1602   ffestorag st;
1603
1604   switch (ffebld_op (expr1))
1605     {
1606     case FFEBLD_opSYMTER:
1607       sym = ffebld_symter (expr1);
1608       break;
1609
1610     case FFEBLD_opARRAYREF:
1611       if (ffebld_op (ffebld_left (expr1)) != FFEBLD_opSYMTER)
1612         return FALSE;
1613       sym = ffebld_symter (ffebld_left (expr1));
1614       break;
1615
1616     default:
1617       return FALSE;
1618     }
1619
1620   if (ffesymbol_where (sym) != FFEINFO_whereCOMMON
1621       && (ffesymbol_where (sym) != FFEINFO_whereLOCAL
1622           || ! (st = ffesymbol_storage (sym))
1623           || ! ffestorag_parent (st)))
1624     return FALSE;
1625
1626   /* It's in COMMON or local EQUIVALENCE.  */
1627
1628   return TRUE;
1629 }
1630
1631 /* Check whether dest and source might overlap.  ffebld versions of these
1632    might or might not be passed, will be NULL if not.
1633
1634    The test is really whether source_tree is modifiable and, if modified,
1635    might overlap destination such that the value(s) in the destination might
1636    change before it is finally modified.  dest_* are the canonized
1637    destination itself.  */
1638
1639 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1640 static bool
1641 ffecom_overlap_ (tree dest_decl, tree dest_offset, tree dest_size,
1642                  tree source_tree, ffebld source UNUSED,
1643                  bool scalar_arg)
1644 {
1645   tree source_decl;
1646   tree source_offset;
1647   tree source_size;
1648   tree t;
1649
1650   if (source_tree == NULL_TREE)
1651     return FALSE;
1652
1653   switch (TREE_CODE (source_tree))
1654     {
1655     case ERROR_MARK:
1656     case IDENTIFIER_NODE:
1657     case INTEGER_CST:
1658     case REAL_CST:
1659     case COMPLEX_CST:
1660     case STRING_CST:
1661     case CONST_DECL:
1662     case VAR_DECL:
1663     case RESULT_DECL:
1664     case FIELD_DECL:
1665     case MINUS_EXPR:
1666     case MULT_EXPR:
1667     case TRUNC_DIV_EXPR:
1668     case CEIL_DIV_EXPR:
1669     case FLOOR_DIV_EXPR:
1670     case ROUND_DIV_EXPR:
1671     case TRUNC_MOD_EXPR:
1672     case CEIL_MOD_EXPR:
1673     case FLOOR_MOD_EXPR:
1674     case ROUND_MOD_EXPR:
1675     case RDIV_EXPR:
1676     case EXACT_DIV_EXPR:
1677     case FIX_TRUNC_EXPR:
1678     case FIX_CEIL_EXPR:
1679     case FIX_FLOOR_EXPR:
1680     case FIX_ROUND_EXPR:
1681     case FLOAT_EXPR:
1682     case EXPON_EXPR:
1683     case NEGATE_EXPR:
1684     case MIN_EXPR:
1685     case MAX_EXPR:
1686     case ABS_EXPR:
1687     case FFS_EXPR:
1688     case LSHIFT_EXPR:
1689     case RSHIFT_EXPR:
1690     case LROTATE_EXPR:
1691     case RROTATE_EXPR:
1692     case BIT_IOR_EXPR:
1693     case BIT_XOR_EXPR:
1694     case BIT_AND_EXPR:
1695     case BIT_ANDTC_EXPR:
1696     case BIT_NOT_EXPR:
1697     case TRUTH_ANDIF_EXPR:
1698     case TRUTH_ORIF_EXPR:
1699     case TRUTH_AND_EXPR:
1700     case TRUTH_OR_EXPR:
1701     case TRUTH_XOR_EXPR:
1702     case TRUTH_NOT_EXPR:
1703     case LT_EXPR:
1704     case LE_EXPR:
1705     case GT_EXPR:
1706     case GE_EXPR:
1707     case EQ_EXPR:
1708     case NE_EXPR:
1709     case COMPLEX_EXPR:
1710     case CONJ_EXPR:
1711     case REALPART_EXPR:
1712     case IMAGPART_EXPR:
1713     case LABEL_EXPR:
1714     case COMPONENT_REF:
1715       return FALSE;
1716
1717     case COMPOUND_EXPR:
1718       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1719                               TREE_OPERAND (source_tree, 1), NULL,
1720                               scalar_arg);
1721
1722     case MODIFY_EXPR:
1723       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1724                               TREE_OPERAND (source_tree, 0), NULL,
1725                               scalar_arg);
1726
1727     case CONVERT_EXPR:
1728     case NOP_EXPR:
1729     case NON_LVALUE_EXPR:
1730     case PLUS_EXPR:
1731       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1732         return TRUE;
1733
1734       ffecom_tree_canonize_ptr_ (&source_decl, &source_offset,
1735                                  source_tree);
1736       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1737       break;
1738
1739     case COND_EXPR:
1740       return
1741         ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1742                          TREE_OPERAND (source_tree, 1), NULL,
1743                          scalar_arg)
1744           || ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1745                               TREE_OPERAND (source_tree, 2), NULL,
1746                               scalar_arg);
1747
1748
1749     case ADDR_EXPR:
1750       ffecom_tree_canonize_ref_ (&source_decl, &source_offset,
1751                                  &source_size,
1752                                  TREE_OPERAND (source_tree, 0));
1753       break;
1754
1755     case PARM_DECL:
1756       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1757         return TRUE;
1758
1759       source_decl = source_tree;
1760       source_offset = size_zero_node;
1761       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1762       break;
1763
1764     case SAVE_EXPR:
1765     case REFERENCE_EXPR:
1766     case PREDECREMENT_EXPR:
1767     case PREINCREMENT_EXPR:
1768     case POSTDECREMENT_EXPR:
1769     case POSTINCREMENT_EXPR:
1770     case INDIRECT_REF:
1771     case ARRAY_REF:
1772     case CALL_EXPR:
1773     default:
1774       return TRUE;
1775     }
1776
1777   /* Come here when source_decl, source_offset, and source_size filled
1778      in appropriately.  */
1779
1780   if (source_decl == NULL_TREE)
1781     return FALSE;               /* No decl involved, so no overlap. */
1782
1783   if (source_decl != dest_decl)
1784     return FALSE;               /* Different decl, no overlap. */
1785
1786   if (TREE_CODE (dest_size) == ERROR_MARK)
1787     return TRUE;                /* Assignment into entire assumed-size
1788                                    array?  Shouldn't happen.... */
1789
1790   t = ffecom_2 (LE_EXPR, integer_type_node,
1791                 ffecom_2 (PLUS_EXPR, TREE_TYPE (dest_offset),
1792                           dest_offset,
1793                           convert (TREE_TYPE (dest_offset),
1794                                    dest_size)),
1795                 convert (TREE_TYPE (dest_offset),
1796                          source_offset));
1797
1798   if (integer_onep (t))
1799     return FALSE;               /* Destination precedes source. */
1800
1801   if (!scalar_arg
1802       || (source_size == NULL_TREE)
1803       || (TREE_CODE (source_size) == ERROR_MARK)
1804       || integer_zerop (source_size))
1805     return TRUE;                /* No way to tell if dest follows source. */
1806
1807   t = ffecom_2 (LE_EXPR, integer_type_node,
1808                 ffecom_2 (PLUS_EXPR, TREE_TYPE (source_offset),
1809                           source_offset,
1810                           convert (TREE_TYPE (source_offset),
1811                                    source_size)),
1812                 convert (TREE_TYPE (source_offset),
1813                          dest_offset));
1814
1815   if (integer_onep (t))
1816     return FALSE;               /* Destination follows source. */
1817
1818   return TRUE;          /* Destination and source overlap. */
1819 }
1820 #endif
1821
1822 /* Check whether dest might overlap any of a list of arguments or is
1823    in a COMMON area the callee might know about (and thus modify).  */
1824
1825 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1826 static bool
1827 ffecom_args_overlapping_ (tree dest_tree, ffebld dest UNUSED,
1828                           tree args, tree callee_commons,
1829                           bool scalar_args)
1830 {
1831   tree arg;
1832   tree dest_decl;
1833   tree dest_offset;
1834   tree dest_size;
1835
1836   ffecom_tree_canonize_ref_ (&dest_decl, &dest_offset, &dest_size,
1837                              dest_tree);
1838
1839   if (dest_decl == NULL_TREE)
1840     return FALSE;               /* Seems unlikely! */
1841
1842   /* If the decl cannot be determined reliably, or if its in COMMON
1843      and the callee isn't known to not futz with COMMON via other
1844      means, overlap might happen.  */
1845
1846   if ((TREE_CODE (dest_decl) == ERROR_MARK)
1847       || ((callee_commons != NULL_TREE)
1848           && TREE_PUBLIC (dest_decl)))
1849     return TRUE;
1850
1851   for (; args != NULL_TREE; args = TREE_CHAIN (args))
1852     {
1853       if (((arg = TREE_VALUE (args)) != NULL_TREE)
1854           && ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1855                               arg, NULL, scalar_args))
1856         return TRUE;
1857     }
1858
1859   return FALSE;
1860 }
1861 #endif
1862
1863 /* Build a string for a variable name as used by NAMELIST.  This means that
1864    if we're using the f2c library, we build an uppercase string, since
1865    f2c does this.  */
1866
1867 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1868 static tree
1869 ffecom_build_f2c_string_ (int i, const char *s)
1870 {
1871   if (!ffe_is_f2c_library ())
1872     return build_string (i, s);
1873
1874   {
1875     char *tmp;
1876     const char *p;
1877     char *q;
1878     char space[34];
1879     tree t;
1880
1881     if (((size_t) i) > ARRAY_SIZE (space))
1882       tmp = malloc_new_ks (malloc_pool_image (), "f2c_string", i);
1883     else
1884       tmp = &space[0];
1885
1886     for (p = s, q = tmp; *p != '\0'; ++p, ++q)
1887       *q = ffesrc_toupper (*p);
1888     *q = '\0';
1889
1890     t = build_string (i, tmp);
1891
1892     if (((size_t) i) > ARRAY_SIZE (space))
1893       malloc_kill_ks (malloc_pool_image (), tmp, i);
1894
1895     return t;
1896   }
1897 }
1898
1899 #endif
1900 /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
1901    type to just get whatever the function returns), handling the
1902    f2c value-returning convention, if required, by prepending
1903    to the arglist a pointer to a temporary to receive the return value.  */
1904
1905 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1906 static tree
1907 ffecom_call_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1908               tree type, tree args, tree dest_tree,
1909               ffebld dest, bool *dest_used, tree callee_commons,
1910               bool scalar_args, tree hook)
1911 {
1912   tree item;
1913   tree tempvar;
1914
1915   if (dest_used != NULL)
1916     *dest_used = FALSE;
1917
1918   if (is_f2c_complex)
1919     {
1920       if ((dest_used == NULL)
1921           || (dest == NULL)
1922           || (ffeinfo_basictype (ffebld_info (dest))
1923               != FFEINFO_basictypeCOMPLEX)
1924           || (ffeinfo_kindtype (ffebld_info (dest)) != kt)
1925           || ((type != NULL_TREE) && (TREE_TYPE (dest_tree) != type))
1926           || ffecom_args_overlapping_ (dest_tree, dest, args,
1927                                        callee_commons,
1928                                        scalar_args))
1929         {
1930 #ifdef HOHO
1931           tempvar = ffecom_make_tempvar (ffecom_tree_type
1932                                          [FFEINFO_basictypeCOMPLEX][kt],
1933                                          FFETARGET_charactersizeNONE,
1934                                          -1);
1935 #else
1936           tempvar = hook;
1937           assert (tempvar);
1938 #endif
1939         }
1940       else
1941         {
1942           *dest_used = TRUE;
1943           tempvar = dest_tree;
1944           type = NULL_TREE;
1945         }
1946
1947       item
1948         = build_tree_list (NULL_TREE,
1949                            ffecom_1 (ADDR_EXPR,
1950                                      build_pointer_type (TREE_TYPE (tempvar)),
1951                                      tempvar));
1952       TREE_CHAIN (item) = args;
1953
1954       item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1955                         item, NULL_TREE);
1956
1957       if (tempvar != dest_tree)
1958         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item, tempvar);
1959     }
1960   else
1961     item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1962                       args, NULL_TREE);
1963
1964   if ((type != NULL_TREE) && (TREE_TYPE (item) != type))
1965     item = ffecom_convert_narrow_ (type, item);
1966
1967   return item;
1968 }
1969 #endif
1970
1971 /* Given two arguments, transform them and make a call to the given
1972    function via ffecom_call_.  */
1973
1974 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1975 static tree
1976 ffecom_call_binop_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1977                     tree type, ffebld left, ffebld right,
1978                     tree dest_tree, ffebld dest, bool *dest_used,
1979                     tree callee_commons, bool scalar_args, tree hook)
1980 {
1981   tree left_tree;
1982   tree right_tree;
1983   tree left_length;
1984   tree right_length;
1985
1986   left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
1987   right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
1988
1989   left_tree = build_tree_list (NULL_TREE, left_tree);
1990   right_tree = build_tree_list (NULL_TREE, right_tree);
1991   TREE_CHAIN (left_tree) = right_tree;
1992
1993   if (left_length != NULL_TREE)
1994     {
1995       left_length = build_tree_list (NULL_TREE, left_length);
1996       TREE_CHAIN (right_tree) = left_length;
1997     }
1998
1999   if (right_length != NULL_TREE)
2000     {
2001       right_length = build_tree_list (NULL_TREE, right_length);
2002       if (left_length != NULL_TREE)
2003         TREE_CHAIN (left_length) = right_length;
2004       else
2005         TREE_CHAIN (right_tree) = right_length;
2006     }
2007
2008   return ffecom_call_ (fn, kt, is_f2c_complex, type, left_tree,
2009                        dest_tree, dest, dest_used, callee_commons,
2010                        scalar_args, hook);
2011 }
2012 #endif
2013
2014 /* Return ptr/length args for char subexpression
2015
2016    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
2017    subexpressions by constructing the appropriate trees for the ptr-to-
2018    character-text and length-of-character-text arguments in a calling
2019    sequence.
2020
2021    Note that if with_null is TRUE, and the expression is an opCONTER,
2022    a null byte is appended to the string.  */
2023
2024 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2025 static void
2026 ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null)
2027 {
2028   tree item;
2029   tree high;
2030   ffetargetCharacter1 val;
2031   ffetargetCharacterSize newlen;
2032
2033   switch (ffebld_op (expr))
2034     {
2035     case FFEBLD_opCONTER:
2036       val = ffebld_constant_character1 (ffebld_conter (expr));
2037       newlen = ffetarget_length_character1 (val);
2038       if (with_null)
2039         {
2040           /* Begin FFETARGET-NULL-KLUDGE.  */
2041           if (newlen != 0)
2042             ++newlen;
2043         }
2044       *length = build_int_2 (newlen, 0);
2045       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2046       high = build_int_2 (newlen, 0);
2047       TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
2048       item = build_string (newlen,
2049                            ffetarget_text_character1 (val));
2050       /* End FFETARGET-NULL-KLUDGE.  */
2051       TREE_TYPE (item)
2052         = build_type_variant
2053           (build_array_type
2054            (char_type_node,
2055             build_range_type
2056             (ffecom_f2c_ftnlen_type_node,
2057              ffecom_f2c_ftnlen_one_node,
2058              high)),
2059            1, 0);
2060       TREE_CONSTANT (item) = 1;
2061       TREE_STATIC (item) = 1;
2062       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
2063                        item);
2064       break;
2065
2066     case FFEBLD_opSYMTER:
2067       {
2068         ffesymbol s = ffebld_symter (expr);
2069
2070         item = ffesymbol_hook (s).decl_tree;
2071         if (item == NULL_TREE)
2072           {
2073             s = ffecom_sym_transform_ (s);
2074             item = ffesymbol_hook (s).decl_tree;
2075           }
2076         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
2077           {
2078             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
2079               *length = ffesymbol_hook (s).length_tree;
2080             else
2081               {
2082                 *length = build_int_2 (ffesymbol_size (s), 0);
2083                 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2084               }
2085           }
2086         else if (item == error_mark_node)
2087           *length = error_mark_node;
2088         else
2089           /* FFEINFO_kindFUNCTION.  */
2090           *length = NULL_TREE;
2091         if (!ffesymbol_hook (s).addr
2092             && (item != error_mark_node))
2093           item = ffecom_1 (ADDR_EXPR,
2094                            build_pointer_type (TREE_TYPE (item)),
2095                            item);
2096       }
2097       break;
2098
2099     case FFEBLD_opARRAYREF:
2100       {
2101         ffecom_char_args_ (&item, length, ffebld_left (expr));
2102
2103         if (item == error_mark_node || *length == error_mark_node)
2104           {
2105             item = *length = error_mark_node;
2106             break;
2107           }
2108
2109         item = ffecom_arrayref_ (item, expr, 1);
2110       }
2111       break;
2112
2113     case FFEBLD_opSUBSTR:
2114       {
2115         ffebld start;
2116         ffebld end;
2117         ffebld thing = ffebld_right (expr);
2118         tree start_tree;
2119         tree end_tree;
2120         char *char_name;
2121         ffebld left_symter;
2122         tree array;
2123
2124         assert (ffebld_op (thing) == FFEBLD_opITEM);
2125         start = ffebld_head (thing);
2126         thing = ffebld_trail (thing);
2127         assert (ffebld_trail (thing) == NULL);
2128         end = ffebld_head (thing);
2129
2130         /* Determine name for pretty-printing range-check errors.  */
2131         for (left_symter = ffebld_left (expr);
2132              left_symter && ffebld_op (left_symter) == FFEBLD_opARRAYREF;
2133              left_symter = ffebld_left (left_symter))
2134           ;
2135         if (ffebld_op (left_symter) == FFEBLD_opSYMTER)
2136           char_name = ffesymbol_text (ffebld_symter (left_symter));
2137         else
2138           char_name = "[expr?]";
2139
2140         ffecom_char_args_ (&item, length, ffebld_left (expr));
2141
2142         if (item == error_mark_node || *length == error_mark_node)
2143           {
2144             item = *length = error_mark_node;
2145             break;
2146           }
2147
2148         array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
2149
2150         /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF.  */
2151
2152         if (start == NULL)
2153           {
2154             if (end == NULL)
2155               ;
2156             else
2157               {
2158                 end_tree = ffecom_expr (end);
2159                 if (ffe_is_subscript_check ())
2160                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2161                                                       char_name);
2162                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2163                                     end_tree);
2164
2165                 if (end_tree == error_mark_node)
2166                   {
2167                     item = *length = error_mark_node;
2168                     break;
2169                   }
2170
2171                 *length = end_tree;
2172               }
2173           }
2174         else
2175           {
2176             start_tree = ffecom_expr (start);
2177             if (ffe_is_subscript_check ())
2178               start_tree = ffecom_subscript_check_ (array, start_tree, 0, 0,
2179                                                     char_name);
2180             start_tree = convert (ffecom_f2c_ftnlen_type_node,
2181                                   start_tree);
2182
2183             if (start_tree == error_mark_node)
2184               {
2185                 item = *length = error_mark_node;
2186                 break;
2187               }
2188
2189             start_tree = ffecom_save_tree (start_tree);
2190
2191             item = ffecom_2 (PLUS_EXPR, TREE_TYPE (item),
2192                              item,
2193                              ffecom_2 (MINUS_EXPR,
2194                                        TREE_TYPE (start_tree),
2195                                        start_tree,
2196                                        ffecom_f2c_ftnlen_one_node));
2197
2198             if (end == NULL)
2199               {
2200                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2201                                     ffecom_f2c_ftnlen_one_node,
2202                                     ffecom_2 (MINUS_EXPR,
2203                                               ffecom_f2c_ftnlen_type_node,
2204                                               *length,
2205                                               start_tree));
2206               }
2207             else
2208               {
2209                 end_tree = ffecom_expr (end);
2210                 if (ffe_is_subscript_check ())
2211                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2212                                                       char_name);
2213                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2214                                     end_tree);
2215
2216                 if (end_tree == error_mark_node)
2217                   {
2218                     item = *length = error_mark_node;
2219                     break;
2220                   }
2221
2222                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2223                                     ffecom_f2c_ftnlen_one_node,
2224                                     ffecom_2 (MINUS_EXPR,
2225                                               ffecom_f2c_ftnlen_type_node,
2226                                               end_tree, start_tree));
2227               }
2228           }
2229       }
2230       break;
2231
2232     case FFEBLD_opFUNCREF:
2233       {
2234         ffesymbol s = ffebld_symter (ffebld_left (expr));
2235         tree tempvar;
2236         tree args;
2237         ffetargetCharacterSize size = ffeinfo_size (ffebld_info (expr));
2238         ffecomGfrt ix;
2239
2240         if (size == FFETARGET_charactersizeNONE)
2241           /* ~~Kludge alert!  This should someday be fixed. */
2242           size = 24;
2243
2244         *length = build_int_2 (size, 0);
2245         TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2246
2247         if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
2248             == FFEINFO_whereINTRINSIC)
2249           {
2250             if (size == 1)
2251               {
2252                 /* Invocation of an intrinsic returning CHARACTER*1.  */
2253                 item = ffecom_expr_intrinsic_ (expr, NULL_TREE,
2254                                                NULL, NULL);
2255                 break;
2256               }
2257             ix = ffeintrin_gfrt_direct (ffebld_symter_implementation (ffebld_left (expr)));
2258             assert (ix != FFECOM_gfrt);
2259             item = ffecom_gfrt_tree_ (ix);
2260           }
2261         else
2262           {
2263             ix = FFECOM_gfrt;
2264             item = ffesymbol_hook (s).decl_tree;
2265             if (item == NULL_TREE)
2266               {
2267                 s = ffecom_sym_transform_ (s);
2268                 item = ffesymbol_hook (s).decl_tree;
2269               }
2270             if (item == error_mark_node)
2271               {
2272                 item = *length = error_mark_node;
2273                 break;
2274               }
2275
2276             if (!ffesymbol_hook (s).addr)
2277               item = ffecom_1_fn (item);
2278           }
2279
2280 #ifdef HOHO
2281         tempvar = ffecom_push_tempvar (char_type_node, size, -1, TRUE);
2282 #else
2283         tempvar = ffebld_nonter_hook (expr);
2284         assert (tempvar);
2285 #endif
2286         tempvar = ffecom_1 (ADDR_EXPR,
2287                             build_pointer_type (TREE_TYPE (tempvar)),
2288                             tempvar);
2289
2290         args = build_tree_list (NULL_TREE, tempvar);
2291
2292         if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)       /* Sfunc args by value. */
2293           TREE_CHAIN (args) = ffecom_list_expr (ffebld_right (expr));
2294         else
2295           {
2296             TREE_CHAIN (args) = build_tree_list (NULL_TREE, *length);
2297             if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
2298               {
2299                 TREE_CHAIN (TREE_CHAIN (args))
2300                   = ffecom_arglist_expr_ (ffecom_gfrt_args_ (ix),
2301                                           ffebld_right (expr));
2302               }
2303             else
2304               {
2305                 TREE_CHAIN (TREE_CHAIN (args))
2306                   = ffecom_list_ptr_to_expr (ffebld_right (expr));
2307               }
2308           }
2309
2310         item = ffecom_3s (CALL_EXPR,
2311                           TREE_TYPE (TREE_TYPE (TREE_TYPE (item))),
2312                           item, args, NULL_TREE);
2313         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item,
2314                          tempvar);
2315       }
2316       break;
2317
2318     case FFEBLD_opCONVERT:
2319
2320       ffecom_char_args_ (&item, length, ffebld_left (expr));
2321
2322       if (item == error_mark_node || *length == error_mark_node)
2323         {
2324           item = *length = error_mark_node;
2325           break;
2326         }
2327
2328       if ((ffebld_size_known (ffebld_left (expr))
2329            == FFETARGET_charactersizeNONE)
2330           || (ffebld_size_known (ffebld_left (expr)) < (ffebld_size (expr))))
2331         {                       /* Possible blank-padding needed, copy into
2332                                    temporary. */
2333           tree tempvar;
2334           tree args;
2335           tree newlen;
2336
2337 #ifdef HOHO
2338           tempvar = ffecom_make_tempvar (char_type_node,
2339                                          ffebld_size (expr), -1);
2340 #else
2341           tempvar = ffebld_nonter_hook (expr);
2342           assert (tempvar);
2343 #endif
2344           tempvar = ffecom_1 (ADDR_EXPR,
2345                               build_pointer_type (TREE_TYPE (tempvar)),
2346                               tempvar);
2347
2348           newlen = build_int_2 (ffebld_size (expr), 0);
2349           TREE_TYPE (newlen) = ffecom_f2c_ftnlen_type_node;
2350
2351           args = build_tree_list (NULL_TREE, tempvar);
2352           TREE_CHAIN (args) = build_tree_list (NULL_TREE, item);
2353           TREE_CHAIN (TREE_CHAIN (args)) = build_tree_list (NULL_TREE, newlen);
2354           TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args)))
2355             = build_tree_list (NULL_TREE, *length);
2356
2357           item = ffecom_call_gfrt (FFECOM_gfrtCOPY, args, NULL_TREE);
2358           TREE_SIDE_EFFECTS (item) = 1;
2359           item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), fold (item),
2360                            tempvar);
2361           *length = newlen;
2362         }
2363       else
2364         {                       /* Just truncate the length. */
2365           *length = build_int_2 (ffebld_size (expr), 0);
2366           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2367         }
2368       break;
2369
2370     default:
2371       assert ("bad op for single char arg expr" == NULL);
2372       item = NULL_TREE;
2373       break;
2374     }
2375
2376   *xitem = item;
2377 }
2378 #endif
2379
2380 /* Check the size of the type to be sure it doesn't overflow the
2381    "portable" capacities of the compiler back end.  `dummy' types
2382    can generally overflow the normal sizes as long as the computations
2383    themselves don't overflow.  A particular target of the back end
2384    must still enforce its size requirements, though, and the back
2385    end takes care of this in stor-layout.c.  */
2386
2387 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2388 static tree
2389 ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy)
2390 {
2391   if (TREE_CODE (type) == ERROR_MARK)
2392     return type;
2393
2394   if (TYPE_SIZE (type) == NULL_TREE)
2395     return type;
2396
2397   if (TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST)
2398     return type;
2399
2400   if ((tree_int_cst_sgn (TYPE_SIZE (type)) < 0)
2401       || (!dummy && (((TREE_INT_CST_HIGH (TYPE_SIZE (type)) != 0))
2402                      || TREE_OVERFLOW (TYPE_SIZE (type)))))
2403     {
2404       ffebad_start (FFEBAD_ARRAY_LARGE);
2405       ffebad_string (ffesymbol_text (s));
2406       ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
2407       ffebad_finish ();
2408
2409       return error_mark_node;
2410     }
2411
2412   return type;
2413 }
2414 #endif
2415
2416 /* Builds a length argument (PARM_DECL).  Also wraps type in an array type
2417    where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
2418    known, length_arg if not known (FFETARGET_charactersizeNONE).  */
2419
2420 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2421 static tree
2422 ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s)
2423 {
2424   ffetargetCharacterSize sz = ffesymbol_size (s);
2425   tree highval;
2426   tree tlen;
2427   tree type = *xtype;
2428
2429   if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
2430     tlen = NULL_TREE;           /* A statement function, no length passed. */
2431   else
2432     {
2433       if (ffesymbol_where (s) == FFEINFO_whereDUMMY)
2434         tlen = ffecom_get_invented_identifier ("__g77_length_%s",
2435                                                ffesymbol_text (s), -1);
2436       else
2437         tlen = ffecom_get_invented_identifier ("__g77_%s",
2438                                                "length", -1);
2439       tlen = build_decl (PARM_DECL, tlen, ffecom_f2c_ftnlen_type_node);
2440 #if BUILT_FOR_270
2441       DECL_ARTIFICIAL (tlen) = 1;
2442 #endif
2443     }
2444
2445   if (sz == FFETARGET_charactersizeNONE)
2446     {
2447       assert (tlen != NULL_TREE);
2448       highval = variable_size (tlen);
2449     }
2450   else
2451     {
2452       highval = build_int_2 (sz, 0);
2453       TREE_TYPE (highval) = ffecom_f2c_ftnlen_type_node;
2454     }
2455
2456   type = build_array_type (type,
2457                            build_range_type (ffecom_f2c_ftnlen_type_node,
2458                                              ffecom_f2c_ftnlen_one_node,
2459                                              highval));
2460
2461   *xtype = type;
2462   return tlen;
2463 }
2464
2465 #endif
2466 /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
2467
2468    ffecomConcatList_ catlist;
2469    ffebld expr;  // expr of CHARACTER basictype.
2470    ffetargetCharacterSize max;  // max chars to gather or _...NONE if no max
2471    catlist = ffecom_concat_list_gather_(catlist,expr,max);
2472
2473    Scans expr for character subexpressions, updates and returns catlist
2474    accordingly.  */
2475
2476 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2477 static ffecomConcatList_
2478 ffecom_concat_list_gather_ (ffecomConcatList_ catlist, ffebld expr,
2479                             ffetargetCharacterSize max)
2480 {
2481   ffetargetCharacterSize sz;
2482
2483 recurse:                        /* :::::::::::::::::::: */
2484
2485   if (expr == NULL)
2486     return catlist;
2487
2488   if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen >= max))
2489     return catlist;             /* Don't append any more items. */
2490
2491   switch (ffebld_op (expr))
2492     {
2493     case FFEBLD_opCONTER:
2494     case FFEBLD_opSYMTER:
2495     case FFEBLD_opARRAYREF:
2496     case FFEBLD_opFUNCREF:
2497     case FFEBLD_opSUBSTR:
2498     case FFEBLD_opCONVERT:      /* Callers should strip this off beforehand
2499                                    if they don't need to preserve it. */
2500       if (catlist.count == catlist.max)
2501         {                       /* Make a (larger) list. */
2502           ffebld *newx;
2503           int newmax;
2504
2505           newmax = (catlist.max == 0) ? 8 : catlist.max * 2;
2506           newx = malloc_new_ks (malloc_pool_image (), "catlist",
2507                                 newmax * sizeof (newx[0]));
2508           if (catlist.max != 0)
2509             {
2510               memcpy (newx, catlist.exprs, catlist.max * sizeof (newx[0]));
2511               malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2512                               catlist.max * sizeof (newx[0]));
2513             }
2514           catlist.max = newmax;
2515           catlist.exprs = newx;
2516         }
2517       if ((sz = ffebld_size_known (expr)) != FFETARGET_charactersizeNONE)
2518         catlist.minlen += sz;
2519       else
2520         ++catlist.minlen;       /* Not true for F90; can be 0 length. */
2521       if ((sz = ffebld_size_max (expr)) == FFETARGET_charactersizeNONE)
2522         catlist.maxlen = sz;
2523       else
2524         catlist.maxlen += sz;
2525       if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen > max))
2526         {                       /* This item overlaps (or is beyond) the end
2527                                    of the destination. */
2528           switch (ffebld_op (expr))
2529             {
2530             case FFEBLD_opCONTER:
2531             case FFEBLD_opSYMTER:
2532             case FFEBLD_opARRAYREF:
2533             case FFEBLD_opFUNCREF:
2534             case FFEBLD_opSUBSTR:
2535               /* ~~Do useful truncations here. */
2536               break;
2537
2538             default:
2539               assert ("op changed or inconsistent switches!" == NULL);
2540               break;
2541             }
2542         }
2543       catlist.exprs[catlist.count++] = expr;
2544       return catlist;
2545
2546     case FFEBLD_opPAREN:
2547       expr = ffebld_left (expr);
2548       goto recurse;             /* :::::::::::::::::::: */
2549
2550     case FFEBLD_opCONCATENATE:
2551       catlist = ffecom_concat_list_gather_ (catlist, ffebld_left (expr), max);
2552       expr = ffebld_right (expr);
2553       goto recurse;             /* :::::::::::::::::::: */
2554
2555 #if 0                           /* Breaks passing small actual arg to larger
2556                                    dummy arg of sfunc */
2557     case FFEBLD_opCONVERT:
2558       expr = ffebld_left (expr);
2559       {
2560         ffetargetCharacterSize cmax;
2561
2562         cmax = catlist.len + ffebld_size_known (expr);
2563
2564         if ((max == FFETARGET_charactersizeNONE) || (max > cmax))
2565           max = cmax;
2566       }
2567       goto recurse;             /* :::::::::::::::::::: */
2568 #endif
2569
2570     case FFEBLD_opANY:
2571       return catlist;
2572
2573     default:
2574       assert ("bad op in _gather_" == NULL);
2575       return catlist;
2576     }
2577 }
2578
2579 #endif
2580 /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
2581
2582    ffecomConcatList_ catlist;
2583    ffecom_concat_list_kill_(catlist);
2584
2585    Anything allocated within the list info is deallocated.  */
2586
2587 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2588 static void
2589 ffecom_concat_list_kill_ (ffecomConcatList_ catlist)
2590 {
2591   if (catlist.max != 0)
2592     malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2593                     catlist.max * sizeof (catlist.exprs[0]));
2594 }
2595
2596 #endif
2597 /* Make list of concatenated string exprs.
2598
2599    Returns a flattened list of concatenated subexpressions given a
2600    tree of such expressions.  */
2601
2602 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2603 static ffecomConcatList_
2604 ffecom_concat_list_new_ (ffebld expr, ffetargetCharacterSize max)
2605 {
2606   ffecomConcatList_ catlist;
2607
2608   catlist.maxlen = catlist.minlen = catlist.max = catlist.count = 0;
2609   return ffecom_concat_list_gather_ (catlist, expr, max);
2610 }
2611
2612 #endif
2613
2614 /* Provide some kind of useful info on member of aggregate area,
2615    since current g77/gcc technology does not provide debug info
2616    on these members.  */
2617
2618 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2619 static void
2620 ffecom_debug_kludge_ (tree aggr, const char *aggr_type, ffesymbol member,
2621                       tree member_type UNUSED, ffetargetOffset offset)
2622 {
2623   tree value;
2624   tree decl;
2625   int len;
2626   char *buff;
2627   char space[120];
2628 #if 0
2629   tree type_id;
2630
2631   for (type_id = member_type;
2632        TREE_CODE (type_id) != IDENTIFIER_NODE;
2633        )
2634     {
2635       switch (TREE_CODE (type_id))
2636         {
2637         case INTEGER_TYPE:
2638         case REAL_TYPE:
2639           type_id = TYPE_NAME (type_id);
2640           break;
2641
2642         case ARRAY_TYPE:
2643         case COMPLEX_TYPE:
2644           type_id = TREE_TYPE (type_id);
2645           break;
2646
2647         default:
2648           assert ("no IDENTIFIER_NODE for type!" == NULL);
2649           type_id = error_mark_node;
2650           break;
2651         }
2652     }
2653 #endif
2654
2655   if (ffecom_transform_only_dummies_
2656       || !ffe_is_debug_kludge ())
2657     return;     /* Can't do this yet, maybe later. */
2658
2659   len = 60
2660     + strlen (aggr_type)
2661     + IDENTIFIER_LENGTH (DECL_NAME (aggr));
2662 #if 0
2663     + IDENTIFIER_LENGTH (type_id);
2664 #endif
2665
2666   if (((size_t) len) >= ARRAY_SIZE (space))
2667     buff = malloc_new_ks (malloc_pool_image (), "debug_kludge", len + 1);
2668   else
2669     buff = &space[0];
2670
2671   sprintf (&buff[0], "At (%s) `%s' plus %ld bytes",
2672            aggr_type,
2673            IDENTIFIER_POINTER (DECL_NAME (aggr)),
2674            (long int) offset);
2675
2676   value = build_string (len, buff);
2677   TREE_TYPE (value)
2678     = build_type_variant (build_array_type (char_type_node,
2679                                             build_range_type
2680                                             (integer_type_node,
2681                                              integer_one_node,
2682                                              build_int_2 (strlen (buff), 0))),
2683                           1, 0);
2684   decl = build_decl (VAR_DECL,
2685                      ffecom_get_identifier_ (ffesymbol_text (member)),
2686                      TREE_TYPE (value));
2687   TREE_CONSTANT (decl) = 1;
2688   TREE_STATIC (decl) = 1;
2689   DECL_INITIAL (decl) = error_mark_node;
2690   DECL_IN_SYSTEM_HEADER (decl) = 1;     /* Don't let -Wunused complain. */
2691   decl = start_decl (decl, FALSE);
2692   finish_decl (decl, value, FALSE);
2693
2694   if (buff != &space[0])
2695     malloc_kill_ks (malloc_pool_image (), buff, len + 1);
2696 }
2697 #endif
2698
2699 /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
2700
2701    ffesymbol fn;  // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
2702    int i;  // entry# for this entrypoint (used by master fn)
2703    ffecom_do_entrypoint_(s,i);
2704
2705    Makes a public entry point that calls our private master fn (already
2706    compiled).  */
2707
2708 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2709 static void
2710 ffecom_do_entry_ (ffesymbol fn, int entrynum)
2711 {
2712   ffebld item;
2713   tree type;                    /* Type of function. */
2714   tree multi_retval;            /* Var holding return value (union). */
2715   tree result;                  /* Var holding result. */
2716   ffeinfoBasictype bt;
2717   ffeinfoKindtype kt;
2718   ffeglobal g;
2719   ffeglobalType gt;
2720   bool charfunc;                /* All entry points return same type
2721                                    CHARACTER. */
2722   bool cmplxfunc;               /* Use f2c way of returning COMPLEX. */
2723   bool multi;                   /* Master fn has multiple return types. */
2724   bool altreturning = FALSE;    /* This entry point has alternate returns. */
2725   int yes;
2726   int old_lineno = lineno;
2727   char *old_input_filename = input_filename;
2728
2729   input_filename = ffesymbol_where_filename (fn);
2730   lineno = ffesymbol_where_filelinenum (fn);
2731
2732   /* c-parse.y indeed does call suspend_momentary and not only ignores the
2733      return value, but also never calls resume_momentary, when starting an
2734      outer function (see "fndef:", "setspecs:", and so on).  So g77 does the
2735      same thing.  It shouldn't be a problem since start_function calls
2736      temporary_allocation, but it might be necessary.  If it causes a problem
2737      here, then maybe there's a bug lurking in gcc.  NOTE: This identical
2738      comment appears twice in thist file.  */
2739
2740   suspend_momentary ();
2741
2742   ffecom_doing_entry_ = TRUE;   /* Don't bother with array dimensions. */
2743
2744   switch (ffecom_primary_entry_kind_)
2745     {
2746     case FFEINFO_kindFUNCTION:
2747
2748       /* Determine actual return type for function. */
2749
2750       gt = FFEGLOBAL_typeFUNC;
2751       bt = ffesymbol_basictype (fn);
2752       kt = ffesymbol_kindtype (fn);
2753       if (bt == FFEINFO_basictypeNONE)
2754         {
2755           ffeimplic_establish_symbol (fn);
2756           if (ffesymbol_funcresult (fn) != NULL)
2757             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
2758           bt = ffesymbol_basictype (fn);
2759           kt = ffesymbol_kindtype (fn);
2760         }
2761
2762       if (bt == FFEINFO_basictypeCHARACTER)
2763         charfunc = TRUE, cmplxfunc = FALSE;
2764       else if ((bt == FFEINFO_basictypeCOMPLEX)
2765                && ffesymbol_is_f2c (fn))
2766         charfunc = FALSE, cmplxfunc = TRUE;
2767       else
2768         charfunc = cmplxfunc = FALSE;
2769
2770       if (charfunc)
2771         type = ffecom_tree_fun_type_void;
2772       else if (ffesymbol_is_f2c (fn))
2773         type = ffecom_tree_fun_type[bt][kt];
2774       else
2775         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
2776
2777       if ((type == NULL_TREE)
2778           || (TREE_TYPE (type) == NULL_TREE))
2779         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
2780
2781       multi = (ffecom_master_bt_ == FFEINFO_basictypeNONE);
2782       break;
2783
2784     case FFEINFO_kindSUBROUTINE:
2785       gt = FFEGLOBAL_typeSUBR;
2786       bt = FFEINFO_basictypeNONE;
2787       kt = FFEINFO_kindtypeNONE;
2788       if (ffecom_is_altreturning_)
2789         {                       /* Am _I_ altreturning? */
2790           for (item = ffesymbol_dummyargs (fn);
2791                item != NULL;
2792                item = ffebld_trail (item))
2793             {
2794               if (ffebld_op (ffebld_head (item)) == FFEBLD_opSTAR)
2795                 {
2796                   altreturning = TRUE;
2797                   break;
2798                 }
2799             }
2800           if (altreturning)
2801             type = ffecom_tree_subr_type;
2802           else
2803             type = ffecom_tree_fun_type_void;
2804         }
2805       else
2806         type = ffecom_tree_fun_type_void;
2807       charfunc = FALSE;
2808       cmplxfunc = FALSE;
2809       multi = FALSE;
2810       break;
2811
2812     default:
2813       assert ("say what??" == NULL);
2814       /* Fall through. */
2815     case FFEINFO_kindANY:
2816       gt = FFEGLOBAL_typeANY;
2817       bt = FFEINFO_basictypeNONE;
2818       kt = FFEINFO_kindtypeNONE;
2819       type = error_mark_node;
2820       charfunc = FALSE;
2821       cmplxfunc = FALSE;
2822       multi = FALSE;
2823       break;
2824     }
2825
2826   /* build_decl uses the current lineno and input_filename to set the decl
2827      source info.  So, I've putzed with ffestd and ffeste code to update that
2828      source info to point to the appropriate statement just before calling
2829      ffecom_do_entrypoint (which calls this fn).  */
2830
2831   start_function (ffecom_get_external_identifier_ (fn),
2832                   type,
2833                   0,            /* nested/inline */
2834                   1);           /* TREE_PUBLIC */
2835
2836   if (((g = ffesymbol_global (fn)) != NULL)
2837       && ((ffeglobal_type (g) == gt)
2838           || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
2839     {
2840       ffeglobal_set_hook (g, current_function_decl);
2841     }
2842
2843   /* Reset args in master arg list so they get retransitioned. */
2844
2845   for (item = ffecom_master_arglist_;
2846        item != NULL;
2847        item = ffebld_trail (item))
2848     {
2849       ffebld arg;
2850       ffesymbol s;
2851
2852       arg = ffebld_head (item);
2853       if (ffebld_op (arg) != FFEBLD_opSYMTER)
2854         continue;               /* Alternate return or some such thing. */
2855       s = ffebld_symter (arg);
2856       ffesymbol_hook (s).decl_tree = NULL_TREE;
2857       ffesymbol_hook (s).length_tree = NULL_TREE;
2858     }
2859
2860   /* Build dummy arg list for this entry point. */
2861
2862   yes = suspend_momentary ();
2863
2864   if (charfunc || cmplxfunc)
2865     {                           /* Prepend arg for where result goes. */
2866       tree type;
2867       tree length;
2868
2869       if (charfunc)
2870         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
2871       else
2872         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
2873
2874       result = ffecom_get_invented_identifier ("__g77_%s",
2875                                                "result", -1);
2876
2877       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
2878
2879       if (charfunc)
2880         length = ffecom_char_enhance_arg_ (&type, fn);
2881       else
2882         length = NULL_TREE;     /* Not ref'd if !charfunc. */
2883
2884       type = build_pointer_type (type);
2885       result = build_decl (PARM_DECL, result, type);
2886
2887       push_parm_decl (result);
2888       ffecom_func_result_ = result;
2889
2890       if (charfunc)
2891         {
2892           push_parm_decl (length);
2893           ffecom_func_length_ = length;
2894         }
2895     }
2896   else
2897     result = DECL_RESULT (current_function_decl);
2898
2899   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn), FALSE);
2900
2901   resume_momentary (yes);
2902
2903   store_parm_decls (0);
2904
2905   ffecom_start_compstmt ();
2906   /* Disallow temp vars at this level.  */
2907   current_binding_level->prep_state = 2;
2908
2909   /* Make local var to hold return type for multi-type master fn. */
2910
2911   if (multi)
2912     {
2913       yes = suspend_momentary ();
2914
2915       multi_retval = ffecom_get_invented_identifier ("__g77_%s",
2916                                                      "multi_retval", -1);
2917       multi_retval = build_decl (VAR_DECL, multi_retval,
2918                                  ffecom_multi_type_node_);
2919       multi_retval = start_decl (multi_retval, FALSE);
2920       finish_decl (multi_retval, NULL_TREE, FALSE);
2921
2922       resume_momentary (yes);
2923     }
2924   else
2925     multi_retval = NULL_TREE;   /* Not actually ref'd if !multi. */
2926
2927   /* Here we emit the actual code for the entry point. */
2928
2929   {
2930     ffebld list;
2931     ffebld arg;
2932     ffesymbol s;
2933     tree arglist = NULL_TREE;
2934     tree *plist = &arglist;
2935     tree prepend;
2936     tree call;
2937     tree actarg;
2938     tree master_fn;
2939
2940     /* Prepare actual arg list based on master arg list. */
2941
2942     for (list = ffecom_master_arglist_;
2943          list != NULL;
2944          list = ffebld_trail (list))
2945       {
2946         arg = ffebld_head (list);
2947         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2948           continue;
2949         s = ffebld_symter (arg);
2950         if (ffesymbol_hook (s).decl_tree == NULL_TREE
2951             || ffesymbol_hook (s).decl_tree == error_mark_node)
2952           actarg = null_pointer_node;   /* We don't have this arg. */
2953         else
2954           actarg = ffesymbol_hook (s).decl_tree;
2955         *plist = build_tree_list (NULL_TREE, actarg);
2956         plist = &TREE_CHAIN (*plist);
2957       }
2958
2959     /* This code appends the length arguments for character
2960        variables/arrays.  */
2961
2962     for (list = ffecom_master_arglist_;
2963          list != NULL;
2964          list = ffebld_trail (list))
2965       {
2966         arg = ffebld_head (list);
2967         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2968           continue;
2969         s = ffebld_symter (arg);
2970         if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
2971           continue;             /* Only looking for CHARACTER arguments. */
2972         if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
2973           continue;             /* Only looking for variables and arrays. */
2974         if (ffesymbol_hook (s).length_tree == NULL_TREE
2975             || ffesymbol_hook (s).length_tree == error_mark_node)
2976           actarg = ffecom_f2c_ftnlen_zero_node; /* We don't have this arg. */
2977         else
2978           actarg = ffesymbol_hook (s).length_tree;
2979         *plist = build_tree_list (NULL_TREE, actarg);
2980         plist = &TREE_CHAIN (*plist);
2981       }
2982
2983     /* Prepend character-value return info to actual arg list. */
2984
2985     if (charfunc)
2986       {
2987         prepend = build_tree_list (NULL_TREE, ffecom_func_result_);
2988         TREE_CHAIN (prepend)
2989           = build_tree_list (NULL_TREE, ffecom_func_length_);
2990         TREE_CHAIN (TREE_CHAIN (prepend)) = arglist;
2991         arglist = prepend;
2992       }
2993
2994     /* Prepend multi-type return value to actual arg list. */
2995
2996     if (multi)
2997       {
2998         prepend
2999           = build_tree_list (NULL_TREE,
3000                              ffecom_1 (ADDR_EXPR,
3001                               build_pointer_type (TREE_TYPE (multi_retval)),
3002                                        multi_retval));
3003         TREE_CHAIN (prepend) = arglist;
3004         arglist = prepend;
3005       }
3006
3007     /* Prepend my entry-point number to the actual arg list. */
3008
3009     prepend = build_tree_list (NULL_TREE, build_int_2 (entrynum, 0));
3010     TREE_CHAIN (prepend) = arglist;
3011     arglist = prepend;
3012
3013     /* Build the call to the master function. */
3014
3015     master_fn = ffecom_1_fn (ffecom_previous_function_decl_);
3016     call = ffecom_3s (CALL_EXPR,
3017                       TREE_TYPE (TREE_TYPE (TREE_TYPE (master_fn))),
3018                       master_fn, arglist, NULL_TREE);
3019
3020     /* Decide whether the master function is a function or subroutine, and
3021        handle the return value for my entry point. */
3022
3023     if (charfunc || ((ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
3024                      && !altreturning))
3025       {
3026         expand_expr_stmt (call);
3027         expand_null_return ();
3028       }
3029     else if (multi && cmplxfunc)
3030       {
3031         expand_expr_stmt (call);
3032         result
3033           = ffecom_1 (INDIRECT_REF,
3034                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
3035                       result);
3036         result = ffecom_modify (NULL_TREE, result,
3037                                 ffecom_2 (COMPONENT_REF, TREE_TYPE (result),
3038                                           multi_retval,
3039                                           ffecom_multi_fields_[bt][kt]));
3040         expand_expr_stmt (result);
3041         expand_null_return ();
3042       }
3043     else if (multi)
3044       {
3045         expand_expr_stmt (call);
3046         result
3047           = ffecom_modify (NULL_TREE, result,
3048                            convert (TREE_TYPE (result),
3049                                     ffecom_2 (COMPONENT_REF,
3050                                               ffecom_tree_type[bt][kt],
3051                                               multi_retval,
3052                                               ffecom_multi_fields_[bt][kt])));
3053         expand_return (result);
3054       }
3055     else if (cmplxfunc)
3056       {
3057         result
3058           = ffecom_1 (INDIRECT_REF,
3059                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
3060                       result);
3061         result = ffecom_modify (NULL_TREE, result, call);
3062         expand_expr_stmt (result);
3063         expand_null_return ();
3064       }
3065     else
3066       {
3067         result = ffecom_modify (NULL_TREE,
3068                                 result,
3069                                 convert (TREE_TYPE (result),
3070                                          call));
3071         expand_return (result);
3072       }
3073
3074     clear_momentary ();
3075   }
3076
3077   ffecom_end_compstmt ();
3078
3079   finish_function (0);
3080
3081   lineno = old_lineno;
3082   input_filename = old_input_filename;
3083
3084   ffecom_doing_entry_ = FALSE;
3085 }
3086
3087 #endif
3088 /* Transform expr into gcc tree with possible destination
3089
3090    Recursive descent on expr while making corresponding tree nodes and
3091    attaching type info and such.  If destination supplied and compatible
3092    with temporary that would be made in certain cases, temporary isn't
3093    made, destination used instead, and dest_used flag set TRUE.  */
3094
3095 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3096 static tree
3097 ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
3098               bool *dest_used, bool assignp, bool widenp)
3099 {
3100   tree item;
3101   tree list;
3102   tree args;
3103   ffeinfoBasictype bt;
3104   ffeinfoKindtype kt;
3105   tree t;
3106   tree dt;                      /* decl_tree for an ffesymbol. */
3107   tree tree_type, tree_type_x;
3108   tree left, right;
3109   ffesymbol s;
3110   enum tree_code code;
3111
3112   assert (expr != NULL);
3113
3114   if (dest_used != NULL)
3115     *dest_used = FALSE;
3116
3117   bt = ffeinfo_basictype (ffebld_info (expr));
3118   kt = ffeinfo_kindtype (ffebld_info (expr));
3119   tree_type = ffecom_tree_type[bt][kt];
3120
3121   /* Widen integral arithmetic as desired while preserving signedness.  */
3122   tree_type_x = NULL_TREE;
3123   if (widenp && tree_type
3124       && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
3125       && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
3126     tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
3127
3128   switch (ffebld_op (expr))
3129     {
3130     case FFEBLD_opACCTER:
3131       {
3132         ffebitCount i;
3133         ffebit bits = ffebld_accter_bits (expr);
3134         ffetargetOffset source_offset = 0;
3135         ffetargetOffset dest_offset = ffebld_accter_pad (expr);
3136         tree purpose;
3137
3138         assert (dest_offset == 0
3139                 || (bt == FFEINFO_basictypeCHARACTER
3140                     && kt == FFEINFO_kindtypeCHARACTER1));
3141
3142         list = item = NULL;
3143         for (;;)
3144           {
3145             ffebldConstantUnion cu;
3146             ffebitCount length;
3147             bool value;
3148             ffebldConstantArray ca = ffebld_accter (expr);
3149
3150             ffebit_test (bits, source_offset, &value, &length);
3151             if (length == 0)
3152               break;
3153
3154             if (value)
3155               {
3156                 for (i = 0; i < length; ++i)
3157                   {
3158                     cu = ffebld_constantarray_get (ca, bt, kt,
3159                                                    source_offset + i);
3160
3161                     t = ffecom_constantunion (&cu, bt, kt, tree_type);
3162
3163                     if (i == 0
3164                         && dest_offset != 0)
3165                       purpose = build_int_2 (dest_offset, 0);
3166                     else
3167                       purpose = NULL_TREE;
3168
3169                     if (list == NULL_TREE)
3170                       list = item = build_tree_list (purpose, t);
3171                     else
3172                       {
3173                         TREE_CHAIN (item) = build_tree_list (purpose, t);
3174                         item = TREE_CHAIN (item);
3175                       }
3176                   }
3177               }
3178             source_offset += length;
3179             dest_offset += length;
3180           }
3181       }
3182
3183       item = build_int_2 ((ffebld_accter_size (expr)
3184                            + ffebld_accter_pad (expr)) - 1, 0);
3185       ffebit_kill (ffebld_accter_bits (expr));
3186       TREE_TYPE (item) = ffecom_integer_type_node;
3187       item
3188         = build_array_type
3189           (tree_type,
3190            build_range_type (ffecom_integer_type_node,
3191                              ffecom_integer_zero_node,
3192                              item));
3193       list = build (CONSTRUCTOR, item, NULL_TREE, list);
3194       TREE_CONSTANT (list) = 1;
3195       TREE_STATIC (list) = 1;
3196       return list;
3197
3198     case FFEBLD_opARRTER:
3199       {
3200         ffetargetOffset i;
3201
3202         list = NULL_TREE;
3203         if (ffebld_arrter_pad (expr) == 0)
3204           item = NULL_TREE;
3205         else
3206           {
3207             assert (bt == FFEINFO_basictypeCHARACTER
3208                     && kt == FFEINFO_kindtypeCHARACTER1);
3209
3210             /* Becomes PURPOSE first time through loop.  */
3211             item = build_int_2 (ffebld_arrter_pad (expr), 0);
3212           }
3213
3214         for (i = 0; i < ffebld_arrter_size (expr); ++i)
3215           {
3216             ffebldConstantUnion cu
3217             = ffebld_constantarray_get (ffebld_arrter (expr), bt, kt, i);
3218
3219             t = ffecom_constantunion (&cu, bt, kt, tree_type);
3220
3221             if (list == NULL_TREE)
3222               /* Assume item is PURPOSE first time through loop.  */
3223               list = item = build_tree_list (item, t);
3224             else
3225               {
3226                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
3227                 item = TREE_CHAIN (item);
3228               }
3229           }
3230       }
3231
3232       item = build_int_2 ((ffebld_arrter_size (expr)
3233                           + ffebld_arrter_pad (expr)) - 1, 0);
3234       TREE_TYPE (item) = ffecom_integer_type_node;
3235       item
3236         = build_array_type
3237           (tree_type,
3238            build_range_type (ffecom_integer_type_node,
3239                              ffecom_integer_zero_node,
3240                              item));
3241       list = build (CONSTRUCTOR, item, NULL_TREE, list);
3242       TREE_CONSTANT (list) = 1;
3243       TREE_STATIC (list) = 1;
3244       return list;
3245
3246     case FFEBLD_opCONTER:
3247       assert (ffebld_conter_pad (expr) == 0);
3248       item
3249         = ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr)),
3250                                 bt, kt, tree_type);
3251       return item;
3252
3253     case FFEBLD_opSYMTER:
3254       if ((ffebld_symter_generic (expr) != FFEINTRIN_genNONE)
3255           || (ffebld_symter_specific (expr) != FFEINTRIN_specNONE))
3256         return ffecom_ptr_to_expr (expr);       /* Same as %REF(intrinsic). */
3257       s = ffebld_symter (expr);
3258       t = ffesymbol_hook (s).decl_tree;
3259
3260       if (assignp)
3261         {                       /* ASSIGN'ed-label expr. */
3262           if (ffe_is_ugly_assign ())
3263             {
3264               /* User explicitly wants ASSIGN'ed variables to be at the same
3265                  memory address as the variables when used in non-ASSIGN
3266                  contexts.  That can make old, arcane, non-standard code
3267                  work, but don't try to do it when a pointer wouldn't fit
3268                  in the normal variable (take other approach, and warn,
3269                  instead).  */
3270
3271               if (t == NULL_TREE)
3272                 {
3273                   s = ffecom_sym_transform_ (s);
3274                   t = ffesymbol_hook (s).decl_tree;
3275                   assert (t != NULL_TREE);
3276                 }
3277
3278               if (t == error_mark_node)
3279                 return t;
3280
3281               if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t)))
3282                   >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
3283                 {
3284                   if (ffesymbol_hook (s).addr)
3285                     t = ffecom_1 (INDIRECT_REF,
3286                                   TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3287                   return t;
3288                 }
3289
3290               if (ffesymbol_hook (s).assign_tree == NULL_TREE)
3291                 {
3292                   ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling",
3293                                     FFEBAD_severityWARNING);
3294                   ffebad_string (ffesymbol_text (s));
3295                   ffebad_here (0, ffesymbol_where_line (s),
3296                                ffesymbol_where_column (s));
3297                   ffebad_finish ();
3298                 }
3299             }
3300
3301           /* Don't use the normal variable's tree for ASSIGN, though mark
3302              it as in the system header (housekeeping).  Use an explicit,
3303              specially created sibling that is known to be wide enough
3304              to hold pointers to labels.  */
3305
3306           if (t != NULL_TREE
3307               && TREE_CODE (t) == VAR_DECL)
3308             DECL_IN_SYSTEM_HEADER (t) = 1;      /* Don't let -Wunused complain. */
3309
3310           t = ffesymbol_hook (s).assign_tree;
3311           if (t == NULL_TREE)
3312             {
3313               s = ffecom_sym_transform_assign_ (s);
3314               t = ffesymbol_hook (s).assign_tree;
3315               assert (t != NULL_TREE);
3316             }
3317         }
3318       else
3319         {
3320           if (t == NULL_TREE)
3321             {
3322               s = ffecom_sym_transform_ (s);
3323               t = ffesymbol_hook (s).decl_tree;
3324               assert (t != NULL_TREE);
3325             }
3326           if (ffesymbol_hook (s).addr)
3327             t = ffecom_1 (INDIRECT_REF,
3328                           TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3329         }
3330       return t;
3331
3332     case FFEBLD_opARRAYREF:
3333       return ffecom_arrayref_ (NULL_TREE, expr, 0);
3334
3335     case FFEBLD_opUPLUS:
3336       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3337       return ffecom_1 (NOP_EXPR, tree_type, left);
3338
3339     case FFEBLD_opPAREN:
3340       /* ~~~Make sure Fortran rules respected here */
3341       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3342       return ffecom_1 (NOP_EXPR, tree_type, left);
3343
3344     case FFEBLD_opUMINUS:
3345       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3346       if (tree_type_x)
3347         {
3348           tree_type = tree_type_x;
3349           left = convert (tree_type, left);
3350         }
3351       return ffecom_1 (NEGATE_EXPR, tree_type, left);
3352
3353     case FFEBLD_opADD:
3354       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3355       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3356       if (tree_type_x)
3357         {
3358           tree_type = tree_type_x;
3359           left = convert (tree_type, left);
3360           right = convert (tree_type, right);
3361         }
3362       return ffecom_2 (PLUS_EXPR, tree_type, left, right);
3363
3364     case FFEBLD_opSUBTRACT:
3365       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3366       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3367       if (tree_type_x)
3368         {
3369           tree_type = tree_type_x;
3370           left = convert (tree_type, left);
3371           right = convert (tree_type, right);
3372         }
3373       return ffecom_2 (MINUS_EXPR, tree_type, left, right);
3374
3375     case FFEBLD_opMULTIPLY:
3376       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3377       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3378       if (tree_type_x)
3379         {
3380           tree_type = tree_type_x;
3381           left = convert (tree_type, left);
3382           right = convert (tree_type, right);
3383         }
3384       return ffecom_2 (MULT_EXPR, tree_type, left, right);
3385
3386     case FFEBLD_opDIVIDE:
3387       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3388       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3389       if (tree_type_x)
3390         {
3391           tree_type = tree_type_x;
3392           left = convert (tree_type, left);
3393           right = convert (tree_type, right);
3394         }
3395       return ffecom_tree_divide_ (tree_type, left, right,
3396                                   dest_tree, dest, dest_used,
3397                                   ffebld_nonter_hook (expr));
3398
3399     case FFEBLD_opPOWER:
3400       {
3401         ffebld left = ffebld_left (expr);
3402         ffebld right = ffebld_right (expr);
3403         ffecomGfrt code;
3404         ffeinfoKindtype rtkt;
3405         ffeinfoKindtype ltkt;
3406
3407         switch (ffeinfo_basictype (ffebld_info (right)))
3408           {
3409           case FFEINFO_basictypeINTEGER:
3410             if (1 || optimize)
3411               {
3412                 item = ffecom_expr_power_integer_ (expr);
3413                 if (item != NULL_TREE)
3414                   return item;
3415               }
3416
3417             rtkt = FFEINFO_kindtypeINTEGER1;
3418             switch (ffeinfo_basictype (ffebld_info (left)))
3419               {
3420               case FFEINFO_basictypeINTEGER:
3421                 if ((ffeinfo_kindtype (ffebld_info (left))
3422                     == FFEINFO_kindtypeINTEGER4)
3423                     || (ffeinfo_kindtype (ffebld_info (right))
3424                         == FFEINFO_kindtypeINTEGER4))
3425                   {
3426                     code = FFECOM_gfrtPOW_QQ;
3427                     ltkt = FFEINFO_kindtypeINTEGER4;
3428                     rtkt = FFEINFO_kindtypeINTEGER4;
3429                   }
3430                 else
3431                   {
3432                     code = FFECOM_gfrtPOW_II;
3433                     ltkt = FFEINFO_kindtypeINTEGER1;
3434                   }
3435                 break;
3436
3437               case FFEINFO_basictypeREAL:
3438                 if (ffeinfo_kindtype (ffebld_info (left))
3439                     == FFEINFO_kindtypeREAL1)
3440                   {
3441                     code = FFECOM_gfrtPOW_RI;
3442                     ltkt = FFEINFO_kindtypeREAL1;
3443                   }
3444                 else
3445                   {
3446                     code = FFECOM_gfrtPOW_DI;
3447                     ltkt = FFEINFO_kindtypeREAL2;
3448                   }
3449                 break;
3450
3451               case FFEINFO_basictypeCOMPLEX:
3452                 if (ffeinfo_kindtype (ffebld_info (left))
3453                     == FFEINFO_kindtypeREAL1)
3454                   {
3455                     code = FFECOM_gfrtPOW_CI;   /* Overlapping result okay. */
3456                     ltkt = FFEINFO_kindtypeREAL1;
3457                   }
3458                 else
3459                   {
3460                     code = FFECOM_gfrtPOW_ZI;   /* Overlapping result okay. */
3461                     ltkt = FFEINFO_kindtypeREAL2;
3462                   }
3463                 break;
3464
3465               default:
3466                 assert ("bad pow_*i" == NULL);
3467                 code = FFECOM_gfrtPOW_CI;       /* Overlapping result okay. */
3468                 ltkt = FFEINFO_kindtypeREAL1;
3469                 break;
3470               }
3471             if (ffeinfo_kindtype (ffebld_info (left)) != ltkt)
3472               left = ffeexpr_convert (left, NULL, NULL,
3473                                       ffeinfo_basictype (ffebld_info (left)),
3474                                       ltkt, 0,
3475                                       FFETARGET_charactersizeNONE,
3476                                       FFEEXPR_contextLET);
3477             if (ffeinfo_kindtype (ffebld_info (right)) != rtkt)
3478               right = ffeexpr_convert (right, NULL, NULL,
3479                                        FFEINFO_basictypeINTEGER,
3480                                        rtkt, 0,
3481                                        FFETARGET_charactersizeNONE,
3482                                        FFEEXPR_contextLET);
3483             break;
3484
3485           case FFEINFO_basictypeREAL:
3486             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3487               left = ffeexpr_convert (left, NULL, NULL, FFEINFO_basictypeREAL,
3488                                       FFEINFO_kindtypeREALDOUBLE, 0,
3489                                       FFETARGET_charactersizeNONE,
3490                                       FFEEXPR_contextLET);
3491             if (ffeinfo_kindtype (ffebld_info (right))
3492                 == FFEINFO_kindtypeREAL1)
3493               right = ffeexpr_convert (right, NULL, NULL,
3494                                        FFEINFO_basictypeREAL,
3495                                        FFEINFO_kindtypeREALDOUBLE, 0,
3496                                        FFETARGET_charactersizeNONE,
3497                                        FFEEXPR_contextLET);
3498             code = FFECOM_gfrtPOW_DD;
3499             break;
3500
3501           case FFEINFO_basictypeCOMPLEX:
3502             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3503               left = ffeexpr_convert (left, NULL, NULL,
3504                                       FFEINFO_basictypeCOMPLEX,
3505                                       FFEINFO_kindtypeREALDOUBLE, 0,
3506                                       FFETARGET_charactersizeNONE,
3507                                       FFEEXPR_contextLET);
3508             if (ffeinfo_kindtype (ffebld_info (right))
3509                 == FFEINFO_kindtypeREAL1)
3510               right = ffeexpr_convert (right, NULL, NULL,
3511                                        FFEINFO_basictypeCOMPLEX,
3512                                        FFEINFO_kindtypeREALDOUBLE, 0,
3513                                        FFETARGET_charactersizeNONE,
3514                                        FFEEXPR_contextLET);
3515             code = FFECOM_gfrtPOW_ZZ;   /* Overlapping result okay. */
3516             break;
3517
3518           default:
3519             assert ("bad pow_x*" == NULL);
3520             code = FFECOM_gfrtPOW_II;
3521             break;
3522           }
3523         return ffecom_call_binop_ (ffecom_gfrt_tree_ (code),
3524                                    ffecom_gfrt_kindtype (code),
3525                                    (ffe_is_f2c_library ()
3526                                     && ffecom_gfrt_complex_[code]),
3527                                    tree_type, left, right,
3528                                    dest_tree, dest, dest_used,
3529                                    NULL_TREE, FALSE,
3530                                    ffebld_nonter_hook (expr));
3531       }
3532
3533     case FFEBLD_opNOT:
3534       switch (bt)
3535         {
3536         case FFEINFO_basictypeLOGICAL:
3537           item = ffecom_truth_value_invert (ffecom_expr (ffebld_left (expr)));
3538           return convert (tree_type, item);
3539
3540         case FFEINFO_basictypeINTEGER:
3541           return ffecom_1 (BIT_NOT_EXPR, tree_type,
3542                            ffecom_expr (ffebld_left (expr)));
3543
3544         default:
3545           assert ("NOT bad basictype" == NULL);
3546           /* Fall through. */
3547         case FFEINFO_basictypeANY:
3548           return error_mark_node;
3549         }
3550       break;
3551
3552     case FFEBLD_opFUNCREF:
3553       assert (ffeinfo_basictype (ffebld_info (expr))
3554               != FFEINFO_basictypeCHARACTER);
3555       /* Fall through.   */
3556     case FFEBLD_opSUBRREF:
3557       if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
3558           == FFEINFO_whereINTRINSIC)
3559         {                       /* Invocation of an intrinsic. */
3560           item = ffecom_expr_intrinsic_ (expr, dest_tree, dest,
3561                                          dest_used);
3562           return item;
3563         }
3564       s = ffebld_symter (ffebld_left (expr));
3565       dt = ffesymbol_hook (s).decl_tree;
3566       if (dt == NULL_TREE)
3567         {
3568           s = ffecom_sym_transform_ (s);
3569           dt = ffesymbol_hook (s).decl_tree;
3570         }
3571       if (dt == error_mark_node)
3572         return dt;
3573
3574       if (ffesymbol_hook (s).addr)
3575         item = dt;
3576       else
3577         item = ffecom_1_fn (dt);
3578
3579       if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
3580         args = ffecom_list_expr (ffebld_right (expr));
3581       else
3582         args = ffecom_list_ptr_to_expr (ffebld_right (expr));
3583
3584       if (args == error_mark_node)
3585         return error_mark_node;
3586
3587       item = ffecom_call_ (item, kt,
3588                            ffesymbol_is_f2c (s)
3589                            && (bt == FFEINFO_basictypeCOMPLEX)
3590                            && (ffesymbol_where (s)
3591                                != FFEINFO_whereCONSTANT),
3592                            tree_type,
3593                            args,
3594                            dest_tree, dest, dest_used,
3595                            error_mark_node, FALSE,
3596                            ffebld_nonter_hook (expr));
3597       TREE_SIDE_EFFECTS (item) = 1;
3598       return item;
3599
3600     case FFEBLD_opAND:
3601       switch (bt)
3602         {
3603         case FFEINFO_basictypeLOGICAL:
3604           item
3605             = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3606                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3607                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3608           return convert (tree_type, item);
3609
3610         case FFEINFO_basictypeINTEGER:
3611           return ffecom_2 (BIT_AND_EXPR, tree_type,
3612                            ffecom_expr (ffebld_left (expr)),
3613                            ffecom_expr (ffebld_right (expr)));
3614
3615         default:
3616           assert ("AND bad basictype" == NULL);
3617           /* Fall through. */
3618         case FFEINFO_basictypeANY:
3619           return error_mark_node;
3620         }
3621       break;
3622
3623     case FFEBLD_opOR:
3624       switch (bt)
3625         {
3626         case FFEINFO_basictypeLOGICAL:
3627           item
3628             = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
3629                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3630                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3631           return convert (tree_type, item);
3632
3633         case FFEINFO_basictypeINTEGER:
3634           return ffecom_2 (BIT_IOR_EXPR, tree_type,
3635                            ffecom_expr (ffebld_left (expr)),
3636                            ffecom_expr (ffebld_right (expr)));
3637
3638         default:
3639           assert ("OR bad basictype" == NULL);
3640           /* Fall through. */
3641         case FFEINFO_basictypeANY:
3642           return error_mark_node;
3643         }
3644       break;
3645
3646     case FFEBLD_opXOR:
3647     case FFEBLD_opNEQV:
3648       switch (bt)
3649         {
3650         case FFEINFO_basictypeLOGICAL:
3651           item
3652             = ffecom_2 (NE_EXPR, integer_type_node,
3653                         ffecom_expr (ffebld_left (expr)),
3654                         ffecom_expr (ffebld_right (expr)));
3655           return convert (tree_type, ffecom_truth_value (item));
3656
3657         case FFEINFO_basictypeINTEGER:
3658           return ffecom_2 (BIT_XOR_EXPR, tree_type,
3659                            ffecom_expr (ffebld_left (expr)),
3660                            ffecom_expr (ffebld_right (expr)));
3661
3662         default:
3663           assert ("XOR/NEQV bad basictype" == NULL);
3664           /* Fall through. */
3665         case FFEINFO_basictypeANY:
3666           return error_mark_node;
3667         }
3668       break;
3669
3670     case FFEBLD_opEQV:
3671       switch (bt)
3672         {
3673         case FFEINFO_basictypeLOGICAL:
3674           item
3675             = ffecom_2 (EQ_EXPR, integer_type_node,
3676                         ffecom_expr (ffebld_left (expr)),
3677                         ffecom_expr (ffebld_right (expr)));
3678           return convert (tree_type, ffecom_truth_value (item));
3679
3680         case FFEINFO_basictypeINTEGER:
3681           return
3682             ffecom_1 (BIT_NOT_EXPR, tree_type,
3683                       ffecom_2 (BIT_XOR_EXPR, tree_type,
3684                                 ffecom_expr (ffebld_left (expr)),
3685                                 ffecom_expr (ffebld_right (expr))));
3686
3687         default:
3688           assert ("EQV bad basictype" == NULL);
3689           /* Fall through. */
3690         case FFEINFO_basictypeANY:
3691           return error_mark_node;
3692         }
3693       break;
3694
3695     case FFEBLD_opCONVERT:
3696       if (ffebld_op (ffebld_left (expr)) == FFEBLD_opANY)
3697         return error_mark_node;
3698
3699       switch (bt)
3700         {
3701         case FFEINFO_basictypeLOGICAL:
3702         case FFEINFO_basictypeINTEGER:
3703         case FFEINFO_basictypeREAL:
3704           return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3705
3706         case FFEINFO_basictypeCOMPLEX:
3707           switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3708             {
3709             case FFEINFO_basictypeINTEGER:
3710             case FFEINFO_basictypeLOGICAL:
3711             case FFEINFO_basictypeREAL:
3712               item = ffecom_expr (ffebld_left (expr));
3713               if (item == error_mark_node)
3714                 return error_mark_node;
3715               /* convert() takes care of converting to the subtype first,
3716                  at least in gcc-2.7.2. */
3717               item = convert (tree_type, item);
3718               return item;
3719
3720             case FFEINFO_basictypeCOMPLEX:
3721               return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3722
3723             default:
3724               assert ("CONVERT COMPLEX bad basictype" == NULL);
3725               /* Fall through. */
3726             case FFEINFO_basictypeANY:
3727               return error_mark_node;
3728             }
3729           break;
3730
3731         default:
3732           assert ("CONVERT bad basictype" == NULL);
3733           /* Fall through. */
3734         case FFEINFO_basictypeANY:
3735           return error_mark_node;
3736         }
3737       break;
3738
3739     case FFEBLD_opLT:
3740       code = LT_EXPR;
3741       goto relational;          /* :::::::::::::::::::: */
3742
3743     case FFEBLD_opLE:
3744       code = LE_EXPR;
3745       goto relational;          /* :::::::::::::::::::: */
3746
3747     case FFEBLD_opEQ:
3748       code = EQ_EXPR;
3749       goto relational;          /* :::::::::::::::::::: */
3750
3751     case FFEBLD_opNE:
3752       code = NE_EXPR;
3753       goto relational;          /* :::::::::::::::::::: */
3754
3755     case FFEBLD_opGT:
3756       code = GT_EXPR;
3757       goto relational;          /* :::::::::::::::::::: */
3758
3759     case FFEBLD_opGE:
3760       code = GE_EXPR;
3761
3762     relational:         /* :::::::::::::::::::: */
3763       switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3764         {
3765         case FFEINFO_basictypeLOGICAL:
3766         case FFEINFO_basictypeINTEGER:
3767         case FFEINFO_basictypeREAL:
3768           item = ffecom_2 (code, integer_type_node,
3769                            ffecom_expr (ffebld_left (expr)),
3770                            ffecom_expr (ffebld_right (expr)));
3771           return convert (tree_type, item);
3772
3773         case FFEINFO_basictypeCOMPLEX:
3774           assert (code == EQ_EXPR || code == NE_EXPR);
3775           {
3776             tree real_type;
3777             tree arg1 = ffecom_expr (ffebld_left (expr));
3778             tree arg2 = ffecom_expr (ffebld_right (expr));
3779
3780             if (arg1 == error_mark_node || arg2 == error_mark_node)
3781               return error_mark_node;
3782
3783             arg1 = ffecom_save_tree (arg1);
3784             arg2 = ffecom_save_tree (arg2);
3785
3786             if (TREE_CODE (TREE_TYPE (arg1)) == COMPLEX_TYPE)
3787               {
3788                 real_type = TREE_TYPE (TREE_TYPE (arg1));
3789                 assert (real_type == TREE_TYPE (TREE_TYPE (arg2)));
3790               }
3791             else
3792               {
3793                 real_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg1)));
3794                 assert (real_type == TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg2))));
3795               }
3796
3797             item
3798               = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3799                           ffecom_2 (EQ_EXPR, integer_type_node,
3800                                   ffecom_1 (REALPART_EXPR, real_type, arg1),
3801                                  ffecom_1 (REALPART_EXPR, real_type, arg2)),
3802                           ffecom_2 (EQ_EXPR, integer_type_node,
3803                                   ffecom_1 (IMAGPART_EXPR, real_type, arg1),
3804                                     ffecom_1 (IMAGPART_EXPR, real_type,
3805                                               arg2)));
3806             if (code == EQ_EXPR)
3807               item = ffecom_truth_value (item);
3808             else
3809               item = ffecom_truth_value_invert (item);
3810             return convert (tree_type, item);
3811           }
3812
3813         case FFEINFO_basictypeCHARACTER:
3814           {
3815             ffebld left = ffebld_left (expr);
3816             ffebld right = ffebld_right (expr);
3817             tree left_tree;
3818             tree right_tree;
3819             tree left_length;
3820             tree right_length;
3821
3822             /* f2c run-time functions do the implicit blank-padding for us,
3823                so we don't usually have to implement blank-padding ourselves.
3824                (The exception is when we pass an argument to a separately
3825                compiled statement function -- if we know the arg is not the
3826                same length as the dummy, we must truncate or extend it.  If
3827                we "inline" statement functions, that necessity goes away as
3828                well.)
3829
3830                Strip off the CONVERT operators that blank-pad.  (Truncation by
3831                CONVERT shouldn't happen here, but it can happen in
3832                assignments.) */
3833
3834             while (ffebld_op (left) == FFEBLD_opCONVERT)
3835               left = ffebld_left (left);
3836             while (ffebld_op (right) == FFEBLD_opCONVERT)
3837               right = ffebld_left (right);
3838
3839             left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
3840             right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
3841
3842             if (left_tree == error_mark_node || left_length == error_mark_node
3843                 || right_tree == error_mark_node
3844                 || right_length == error_mark_node)
3845               return error_mark_node;
3846
3847             if ((ffebld_size_known (left) == 1)
3848                 && (ffebld_size_known (right) == 1))
3849               {
3850                 left_tree
3851                   = ffecom_1 (INDIRECT_REF,
3852                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3853                               left_tree);
3854                 right_tree
3855                   = ffecom_1 (INDIRECT_REF,
3856                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3857                               right_tree);
3858
3859                 item
3860                   = ffecom_2 (code, integer_type_node,
3861                               ffecom_2 (ARRAY_REF,
3862                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3863                                         left_tree,
3864                                         integer_one_node),
3865                               ffecom_2 (ARRAY_REF,
3866                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3867                                         right_tree,
3868                                         integer_one_node));
3869               }
3870             else
3871               {
3872                 item = build_tree_list (NULL_TREE, left_tree);
3873                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, right_tree);
3874                 TREE_CHAIN (TREE_CHAIN (item)) = build_tree_list (NULL_TREE,
3875                                                                left_length);
3876                 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
3877                   = build_tree_list (NULL_TREE, right_length);
3878                 item = ffecom_call_gfrt (FFECOM_gfrtCMP, item, NULL_TREE);
3879                 item = ffecom_2 (code, integer_type_node,
3880                                  item,
3881                                  convert (TREE_TYPE (item),
3882                                           integer_zero_node));
3883               }
3884             item = convert (tree_type, item);
3885           }
3886
3887           return item;
3888
3889         default:
3890           assert ("relational bad basictype" == NULL);
3891           /* Fall through. */
3892         case FFEINFO_basictypeANY:
3893           return error_mark_node;
3894         }
3895       break;
3896
3897     case FFEBLD_opPERCENT_LOC:
3898       item = ffecom_arg_ptr_to_expr (ffebld_left (expr), &list);
3899       return convert (tree_type, item);
3900
3901     case FFEBLD_opITEM:
3902     case FFEBLD_opSTAR:
3903     case FFEBLD_opBOUNDS:
3904     case FFEBLD_opREPEAT:
3905     case FFEBLD_opLABTER:
3906     case FFEBLD_opLABTOK:
3907     case FFEBLD_opIMPDO:
3908     case FFEBLD_opCONCATENATE:
3909     case FFEBLD_opSUBSTR:
3910     default:
3911       assert ("bad op" == NULL);
3912       /* Fall through. */
3913     case FFEBLD_opANY:
3914       return error_mark_node;
3915     }
3916
3917 #if 1
3918   assert ("didn't think anything got here anymore!!" == NULL);
3919 #else
3920   switch (ffebld_arity (expr))
3921     {
3922     case 2:
3923       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3924       TREE_OPERAND (item, 1) = ffecom_expr (ffebld_right (expr));
3925       if (TREE_OPERAND (item, 0) == error_mark_node
3926           || TREE_OPERAND (item, 1) == error_mark_node)
3927         return error_mark_node;
3928       break;
3929
3930     case 1:
3931       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3932       if (TREE_OPERAND (item, 0) == error_mark_node)
3933         return error_mark_node;
3934       break;
3935
3936     default:
3937       break;
3938     }
3939
3940   return fold (item);
3941 #endif
3942 }
3943
3944 #endif
3945 /* Returns the tree that does the intrinsic invocation.
3946
3947    Note: this function applies only to intrinsics returning
3948    CHARACTER*1 or non-CHARACTER results, and to intrinsic
3949    subroutines.  */
3950
3951 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3952 static tree
3953 ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
3954                         ffebld dest, bool *dest_used)
3955 {
3956   tree expr_tree;
3957   tree saved_expr1;             /* For those who need it. */
3958   tree saved_expr2;             /* For those who need it. */
3959   ffeinfoBasictype bt;
3960   ffeinfoKindtype kt;
3961   tree tree_type;
3962   tree arg1_type;
3963   tree real_type;               /* REAL type corresponding to COMPLEX. */
3964   tree tempvar;
3965   ffebld list = ffebld_right (expr);    /* List of (some) args. */
3966   ffebld arg1;                  /* For handy reference. */
3967   ffebld arg2;
3968   ffebld arg3;
3969   ffeintrinImp codegen_imp;
3970   ffecomGfrt gfrt;
3971
3972   assert (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER);
3973
3974   if (dest_used != NULL)
3975     *dest_used = FALSE;
3976
3977   bt = ffeinfo_basictype (ffebld_info (expr));
3978   kt = ffeinfo_kindtype (ffebld_info (expr));
3979   tree_type = ffecom_tree_type[bt][kt];
3980
3981   if (list != NULL)
3982     {
3983       arg1 = ffebld_head (list);
3984       if (arg1 != NULL && ffebld_op (arg1) == FFEBLD_opANY)
3985         return error_mark_node;
3986       if ((list = ffebld_trail (list)) != NULL)
3987         {
3988           arg2 = ffebld_head (list);
3989           if (arg2 != NULL && ffebld_op (arg2) == FFEBLD_opANY)
3990             return error_mark_node;
3991           if ((list = ffebld_trail (list)) != NULL)
3992             {
3993               arg3 = ffebld_head (list);
3994               if (arg3 != NULL && ffebld_op (arg3) == FFEBLD_opANY)
3995                 return error_mark_node;
3996             }
3997           else
3998             arg3 = NULL;
3999         }
4000       else
4001         arg2 = arg3 = NULL;
4002     }
4003   else
4004     arg1 = arg2 = arg3 = NULL;
4005
4006   /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
4007      args.  This is used by the MAX/MIN expansions. */
4008
4009   if (arg1 != NULL)
4010     arg1_type = ffecom_tree_type
4011       [ffeinfo_basictype (ffebld_info (arg1))]
4012       [ffeinfo_kindtype (ffebld_info (arg1))];
4013   else
4014     arg1_type = NULL_TREE;      /* Really not needed, but might catch bugs
4015                                    here. */
4016
4017   /* There are several ways for each of the cases in the following switch
4018      statements to exit (from simplest to use to most complicated):
4019
4020      break;  (when expr_tree == NULL)
4021
4022      A standard call is made to the specific intrinsic just as if it had been
4023      passed in as a dummy procedure and called as any old procedure.  This
4024      method can produce slower code but in some cases it's the easiest way for
4025      now.  However, if a (presumably faster) direct call is available,
4026      that is used, so this is the easiest way in many more cases now.
4027
4028      gfrt = FFECOM_gfrtWHATEVER;
4029      break;
4030
4031      gfrt contains the gfrt index of a library function to call, passing the
4032      argument(s) by value rather than by reference.  Used when a more
4033      careful choice of library function is needed than that provided
4034      by the vanilla `break;'.
4035
4036      return expr_tree;
4037
4038      The expr_tree has been completely set up and is ready to be returned
4039      as is.  No further actions are taken.  Use this when the tree is not
4040      in the simple form for one of the arity_n labels.   */
4041
4042   /* For info on how the switch statement cases were written, see the files
4043      enclosed in comments below the switch statement. */
4044
4045   codegen_imp = ffebld_symter_implementation (ffebld_left (expr));
4046   gfrt = ffeintrin_gfrt_direct (codegen_imp);
4047   if (gfrt == FFECOM_gfrt)
4048     gfrt = ffeintrin_gfrt_indirect (codegen_imp);
4049
4050   switch (codegen_imp)
4051     {
4052     case FFEINTRIN_impABS:
4053     case FFEINTRIN_impCABS:
4054     case FFEINTRIN_impCDABS:
4055     case FFEINTRIN_impDABS:
4056     case FFEINTRIN_impIABS:
4057       if (ffeinfo_basictype (ffebld_info (arg1))
4058           == FFEINFO_basictypeCOMPLEX)
4059         {
4060           if (kt == FFEINFO_kindtypeREAL1)
4061             gfrt = FFECOM_gfrtCABS;
4062           else if (kt == FFEINFO_kindtypeREAL2)
4063             gfrt = FFECOM_gfrtCDABS;
4064           break;
4065         }
4066       return ffecom_1 (ABS_EXPR, tree_type,
4067                        convert (tree_type, ffecom_expr (arg1)));
4068
4069     case FFEINTRIN_impACOS:
4070     case FFEINTRIN_impDACOS:
4071       break;
4072
4073     case FFEINTRIN_impAIMAG:
4074     case FFEINTRIN_impDIMAG:
4075     case FFEINTRIN_impIMAGPART:
4076       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
4077         arg1_type = TREE_TYPE (arg1_type);
4078       else
4079         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
4080
4081       return
4082         convert (tree_type,
4083                  ffecom_1 (IMAGPART_EXPR, arg1_type,
4084                            ffecom_expr (arg1)));
4085
4086     case FFEINTRIN_impAINT:
4087     case FFEINTRIN_impDINT:
4088 #if 0
4089       /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg.  */
4090       return ffecom_1 (FIX_TRUNC_EXPR, tree_type, ffecom_expr (arg1));
4091 #else /* in the meantime, must use floor to avoid range problems with ints */
4092       /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
4093       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4094       return
4095         convert (tree_type,
4096                  ffecom_3 (COND_EXPR, double_type_node,
4097                            ffecom_truth_value
4098                            (ffecom_2 (GE_EXPR, integer_type_node,
4099                                       saved_expr1,
4100                                       convert (arg1_type,
4101                                                ffecom_float_zero_))),
4102                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4103                                              build_tree_list (NULL_TREE,
4104                                                   convert (double_type_node,
4105                                                            saved_expr1)),
4106                                              NULL_TREE),
4107                            ffecom_1 (NEGATE_EXPR, double_type_node,
4108                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4109                                                  build_tree_list (NULL_TREE,
4110                                                   convert (double_type_node,
4111                                                       ffecom_1 (NEGATE_EXPR,
4112                                                                 arg1_type,
4113                                                                saved_expr1))),
4114                                                        NULL_TREE)
4115                                      ))
4116                  );
4117 #endif
4118
4119     case FFEINTRIN_impANINT:
4120     case FFEINTRIN_impDNINT:
4121 #if 0                           /* This way of doing it won't handle real
4122                                    numbers of large magnitudes. */
4123       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4124       expr_tree = convert (tree_type,
4125                            convert (integer_type_node,
4126                                     ffecom_3 (COND_EXPR, tree_type,
4127                                               ffecom_truth_value
4128                                               (ffecom_2 (GE_EXPR,
4129                                                          integer_type_node,
4130                                                          saved_expr1,
4131                                                        ffecom_float_zero_)),
4132                                               ffecom_2 (PLUS_EXPR,
4133                                                         tree_type,
4134                                                         saved_expr1,
4135                                                         ffecom_float_half_),
4136                                               ffecom_2 (MINUS_EXPR,
4137                                                         tree_type,
4138                                                         saved_expr1,
4139                                                      ffecom_float_half_))));
4140       return expr_tree;
4141 #else /* So we instead call floor. */
4142       /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
4143       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4144       return
4145         convert (tree_type,
4146                  ffecom_3 (COND_EXPR, double_type_node,
4147                            ffecom_truth_value
4148                            (ffecom_2 (GE_EXPR, integer_type_node,
4149                                       saved_expr1,
4150                                       convert (arg1_type,
4151                                                ffecom_float_zero_))),
4152                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4153                                              build_tree_list (NULL_TREE,
4154                                                   convert (double_type_node,
4155                                                            ffecom_2 (PLUS_EXPR,
4156                                                                      arg1_type,
4157                                                                      saved_expr1,
4158                                                                      convert (arg1_type,
4159                                                                               ffecom_float_half_)))),
4160                                              NULL_TREE),
4161                            ffecom_1 (NEGATE_EXPR, double_type_node,
4162                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4163                                                        build_tree_list (NULL_TREE,
4164                                                                         convert (double_type_node,
4165                                                                                  ffecom_2 (MINUS_EXPR,
4166                                                                                            arg1_type,
4167                                                                                            convert (arg1_type,
4168                                                                                                     ffecom_float_half_),
4169                                                                                            saved_expr1))),
4170                                                        NULL_TREE))
4171                            )
4172                  );
4173 #endif
4174
4175     case FFEINTRIN_impASIN:
4176     case FFEINTRIN_impDASIN:
4177     case FFEINTRIN_impATAN:
4178     case FFEINTRIN_impDATAN:
4179     case FFEINTRIN_impATAN2:
4180     case FFEINTRIN_impDATAN2:
4181       break;
4182
4183     case FFEINTRIN_impCHAR:
4184     case FFEINTRIN_impACHAR:
4185 #ifdef HOHO
4186       tempvar = ffecom_make_tempvar (char_type_node, 1, -1);
4187 #else
4188       tempvar = ffebld_nonter_hook (expr);
4189       assert (tempvar);
4190 #endif
4191       {
4192         tree tmv = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar)));
4193
4194         expr_tree = ffecom_modify (tmv,
4195                                    ffecom_2 (ARRAY_REF, tmv, tempvar,
4196                                              integer_one_node),
4197                                    convert (tmv, ffecom_expr (arg1)));
4198       }
4199       expr_tree = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar),
4200                             expr_tree,
4201                             tempvar);
4202       expr_tree = ffecom_1 (ADDR_EXPR,
4203                             build_pointer_type (TREE_TYPE (expr_tree)),
4204                             expr_tree);
4205       return expr_tree;
4206
4207     case FFEINTRIN_impCMPLX:
4208     case FFEINTRIN_impDCMPLX:
4209       if (arg2 == NULL)
4210         return
4211           convert (tree_type, ffecom_expr (arg1));
4212
4213       real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4214       return
4215         ffecom_2 (COMPLEX_EXPR, tree_type,
4216                   convert (real_type, ffecom_expr (arg1)),
4217                   convert (real_type,
4218                            ffecom_expr (arg2)));
4219
4220     case FFEINTRIN_impCOMPLEX:
4221       return
4222         ffecom_2 (COMPLEX_EXPR, tree_type,
4223                   ffecom_expr (arg1),
4224                   ffecom_expr (arg2));
4225
4226     case FFEINTRIN_impCONJG:
4227     case FFEINTRIN_impDCONJG:
4228       {
4229         tree arg1_tree;
4230
4231         real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4232         arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4233         return
4234           ffecom_2 (COMPLEX_EXPR, tree_type,
4235                     ffecom_1 (REALPART_EXPR, real_type, arg1_tree),
4236                     ffecom_1 (NEGATE_EXPR, real_type,
4237                               ffecom_1 (IMAGPART_EXPR, real_type, arg1_tree)));
4238       }
4239
4240     case FFEINTRIN_impCOS:
4241     case FFEINTRIN_impCCOS:
4242     case FFEINTRIN_impCDCOS:
4243     case FFEINTRIN_impDCOS:
4244       if (bt == FFEINFO_basictypeCOMPLEX)
4245         {
4246           if (kt == FFEINFO_kindtypeREAL1)
4247             gfrt = FFECOM_gfrtCCOS;     /* Overlapping result okay. */
4248           else if (kt == FFEINFO_kindtypeREAL2)
4249             gfrt = FFECOM_gfrtCDCOS;    /* Overlapping result okay. */
4250         }
4251       break;
4252
4253     case FFEINTRIN_impCOSH:
4254     case FFEINTRIN_impDCOSH:
4255       break;
4256
4257     case FFEINTRIN_impDBLE:
4258     case FFEINTRIN_impDFLOAT:
4259     case FFEINTRIN_impDREAL:
4260     case FFEINTRIN_impFLOAT:
4261     case FFEINTRIN_impIDINT:
4262     case FFEINTRIN_impIFIX:
4263     case FFEINTRIN_impINT2:
4264     case FFEINTRIN_impINT8:
4265     case FFEINTRIN_impINT:
4266     case FFEINTRIN_impLONG:
4267     case FFEINTRIN_impREAL:
4268     case FFEINTRIN_impSHORT:
4269     case FFEINTRIN_impSNGL:
4270       return convert (tree_type, ffecom_expr (arg1));
4271
4272     case FFEINTRIN_impDIM:
4273     case FFEINTRIN_impDDIM:
4274     case FFEINTRIN_impIDIM:
4275       saved_expr1 = ffecom_save_tree (convert (tree_type,
4276                                                ffecom_expr (arg1)));
4277       saved_expr2 = ffecom_save_tree (convert (tree_type,
4278                                                ffecom_expr (arg2)));
4279       return
4280         ffecom_3 (COND_EXPR, tree_type,
4281                   ffecom_truth_value
4282                   (ffecom_2 (GT_EXPR, integer_type_node,
4283                              saved_expr1,
4284                              saved_expr2)),
4285                   ffecom_2 (MINUS_EXPR, tree_type,
4286                             saved_expr1,
4287                             saved_expr2),
4288                   convert (tree_type, ffecom_float_zero_));
4289
4290     case FFEINTRIN_impDPROD:
4291       return
4292         ffecom_2 (MULT_EXPR, tree_type,
4293                   convert (tree_type, ffecom_expr (arg1)),
4294                   convert (tree_type, ffecom_expr (arg2)));
4295
4296     case FFEINTRIN_impEXP:
4297     case FFEINTRIN_impCDEXP:
4298     case FFEINTRIN_impCEXP:
4299     case FFEINTRIN_impDEXP:
4300       if (bt == FFEINFO_basictypeCOMPLEX)
4301         {
4302           if (kt == FFEINFO_kindtypeREAL1)
4303             gfrt = FFECOM_gfrtCEXP;     /* Overlapping result okay. */
4304           else if (kt == FFEINFO_kindtypeREAL2)
4305             gfrt = FFECOM_gfrtCDEXP;    /* Overlapping result okay. */
4306         }
4307       break;
4308
4309     case FFEINTRIN_impICHAR:
4310     case FFEINTRIN_impIACHAR:
4311 #if 0                           /* The simple approach. */
4312       ffecom_char_args_ (&expr_tree, &saved_expr1 /* Ignored */ , arg1);
4313       expr_tree
4314         = ffecom_1 (INDIRECT_REF,
4315                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4316                     expr_tree);
4317       expr_tree
4318         = ffecom_2 (ARRAY_REF,
4319                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4320                     expr_tree,
4321                     integer_one_node);
4322       return convert (tree_type, expr_tree);
4323 #else /* The more interesting (and more optimal) approach. */
4324       expr_tree = ffecom_intrinsic_ichar_ (tree_type, arg1, &saved_expr1);
4325       expr_tree = ffecom_3 (COND_EXPR, tree_type,
4326                             saved_expr1,
4327                             expr_tree,
4328                             convert (tree_type, integer_zero_node));
4329       return expr_tree;
4330 #endif
4331
4332     case FFEINTRIN_impINDEX:
4333       break;
4334
4335     case FFEINTRIN_impLEN:
4336 #if 0
4337       break;                                    /* The simple approach. */
4338 #else
4339       return ffecom_intrinsic_len_ (arg1);      /* The more optimal approach. */
4340 #endif
4341
4342     case FFEINTRIN_impLGE:
4343     case FFEINTRIN_impLGT:
4344     case FFEINTRIN_impLLE:
4345     case FFEINTRIN_impLLT:
4346       break;
4347
4348     case FFEINTRIN_impLOG:
4349     case FFEINTRIN_impALOG:
4350     case FFEINTRIN_impCDLOG:
4351     case FFEINTRIN_impCLOG:
4352     case FFEINTRIN_impDLOG:
4353       if (bt == FFEINFO_basictypeCOMPLEX)
4354         {
4355           if (kt == FFEINFO_kindtypeREAL1)
4356             gfrt = FFECOM_gfrtCLOG;     /* Overlapping result okay. */
4357           else if (kt == FFEINFO_kindtypeREAL2)
4358             gfrt = FFECOM_gfrtCDLOG;    /* Overlapping result okay. */
4359         }
4360       break;
4361
4362     case FFEINTRIN_impLOG10:
4363     case FFEINTRIN_impALOG10:
4364     case FFEINTRIN_impDLOG10:
4365       if (gfrt != FFECOM_gfrt)
4366         break;  /* Already picked one, stick with it. */
4367
4368       if (kt == FFEINFO_kindtypeREAL1)
4369         gfrt = FFECOM_gfrtALOG10;
4370       else if (kt == FFEINFO_kindtypeREAL2)
4371         gfrt = FFECOM_gfrtDLOG10;
4372       break;
4373
4374     case FFEINTRIN_impMAX:
4375     case FFEINTRIN_impAMAX0:
4376     case FFEINTRIN_impAMAX1:
4377     case FFEINTRIN_impDMAX1:
4378     case FFEINTRIN_impMAX0:
4379     case FFEINTRIN_impMAX1:
4380       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4381         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4382       else
4383         arg1_type = tree_type;
4384       expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4385                             convert (arg1_type, ffecom_expr (arg1)),
4386                             convert (arg1_type, ffecom_expr (arg2)));
4387       for (; list != NULL; list = ffebld_trail (list))
4388         {
4389           if ((ffebld_head (list) == NULL)
4390               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4391             continue;
4392           expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4393                                 expr_tree,
4394                                 convert (arg1_type,
4395                                          ffecom_expr (ffebld_head (list))));
4396         }
4397       return convert (tree_type, expr_tree);
4398
4399     case FFEINTRIN_impMIN:
4400     case FFEINTRIN_impAMIN0:
4401     case FFEINTRIN_impAMIN1:
4402     case FFEINTRIN_impDMIN1:
4403     case FFEINTRIN_impMIN0:
4404     case FFEINTRIN_impMIN1:
4405       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4406         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4407       else
4408         arg1_type = tree_type;
4409       expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4410                             convert (arg1_type, ffecom_expr (arg1)),
4411                             convert (arg1_type, ffecom_expr (arg2)));
4412       for (; list != NULL; list = ffebld_trail (list))
4413         {
4414           if ((ffebld_head (list) == NULL)
4415               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4416             continue;
4417           expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4418                                 expr_tree,
4419                                 convert (arg1_type,
4420                                          ffecom_expr (ffebld_head (list))));
4421         }
4422       return convert (tree_type, expr_tree);
4423
4424     case FFEINTRIN_impMOD:
4425     case FFEINTRIN_impAMOD:
4426     case FFEINTRIN_impDMOD:
4427       if (bt != FFEINFO_basictypeREAL)
4428         return ffecom_2 (TRUNC_MOD_EXPR, tree_type,
4429                          convert (tree_type, ffecom_expr (arg1)),
4430                          convert (tree_type, ffecom_expr (arg2)));
4431
4432       if (kt == FFEINFO_kindtypeREAL1)
4433         gfrt = FFECOM_gfrtAMOD;
4434       else if (kt == FFEINFO_kindtypeREAL2)
4435         gfrt = FFECOM_gfrtDMOD;
4436       break;
4437
4438     case FFEINTRIN_impNINT:
4439     case FFEINTRIN_impIDNINT:
4440 #if 0
4441       /* ~~Ideally FIX_ROUND_EXPR would be implemented, but it ain't yet.  */
4442       return ffecom_1 (FIX_ROUND_EXPR, tree_type, ffecom_expr (arg1));
4443 #else
4444       /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
4445       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4446       return
4447         convert (ffecom_integer_type_node,
4448                  ffecom_3 (COND_EXPR, arg1_type,
4449                            ffecom_truth_value
4450                            (ffecom_2 (GE_EXPR, integer_type_node,
4451                                       saved_expr1,
4452                                       convert (arg1_type,
4453                                                ffecom_float_zero_))),
4454                            ffecom_2 (PLUS_EXPR, arg1_type,
4455                                      saved_expr1,
4456                                      convert (arg1_type,
4457                                               ffecom_float_half_)),
4458                            ffecom_2 (MINUS_EXPR, arg1_type,
4459                                      saved_expr1,
4460                                      convert (arg1_type,
4461                                               ffecom_float_half_))));
4462 #endif
4463
4464     case FFEINTRIN_impSIGN:
4465     case FFEINTRIN_impDSIGN:
4466     case FFEINTRIN_impISIGN:
4467       {
4468         tree arg2_tree = ffecom_expr (arg2);
4469
4470         saved_expr1
4471           = ffecom_save_tree
4472           (ffecom_1 (ABS_EXPR, tree_type,
4473                      convert (tree_type,
4474                               ffecom_expr (arg1))));
4475         expr_tree
4476           = ffecom_3 (COND_EXPR, tree_type,
4477                       ffecom_truth_value
4478                       (ffecom_2 (GE_EXPR, integer_type_node,
4479                                  arg2_tree,
4480                                  convert (TREE_TYPE (arg2_tree),
4481                                           integer_zero_node))),
4482                       saved_expr1,
4483                       ffecom_1 (NEGATE_EXPR, tree_type, saved_expr1));
4484         /* Make sure SAVE_EXPRs get referenced early enough. */
4485         expr_tree
4486           = ffecom_2 (COMPOUND_EXPR, tree_type,
4487                       convert (void_type_node, saved_expr1),
4488                       expr_tree);
4489       }
4490       return expr_tree;
4491
4492     case FFEINTRIN_impSIN:
4493     case FFEINTRIN_impCDSIN:
4494     case FFEINTRIN_impCSIN:
4495     case FFEINTRIN_impDSIN:
4496       if (bt == FFEINFO_basictypeCOMPLEX)
4497         {
4498           if (kt == FFEINFO_kindtypeREAL1)
4499             gfrt = FFECOM_gfrtCSIN;     /* Overlapping result okay. */
4500           else if (kt == FFEINFO_kindtypeREAL2)
4501             gfrt = FFECOM_gfrtCDSIN;    /* Overlapping result okay. */
4502         }
4503       break;
4504
4505     case FFEINTRIN_impSINH:
4506     case FFEINTRIN_impDSINH:
4507       break;
4508
4509     case FFEINTRIN_impSQRT:
4510     case FFEINTRIN_impCDSQRT:
4511     case FFEINTRIN_impCSQRT:
4512     case FFEINTRIN_impDSQRT:
4513       if (bt == FFEINFO_basictypeCOMPLEX)
4514         {
4515           if (kt == FFEINFO_kindtypeREAL1)
4516             gfrt = FFECOM_gfrtCSQRT;    /* Overlapping result okay. */
4517           else if (kt == FFEINFO_kindtypeREAL2)
4518             gfrt = FFECOM_gfrtCDSQRT;   /* Overlapping result okay. */
4519         }
4520       break;
4521
4522     case FFEINTRIN_impTAN:
4523     case FFEINTRIN_impDTAN:
4524     case FFEINTRIN_impTANH:
4525     case FFEINTRIN_impDTANH:
4526       break;
4527
4528     case FFEINTRIN_impREALPART:
4529       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
4530         arg1_type = TREE_TYPE (arg1_type);
4531       else
4532         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
4533
4534       return
4535         convert (tree_type,
4536                  ffecom_1 (REALPART_EXPR, arg1_type,
4537                            ffecom_expr (arg1)));
4538
4539     case FFEINTRIN_impIAND:
4540     case FFEINTRIN_impAND:
4541       return ffecom_2 (BIT_AND_EXPR, tree_type,
4542                        convert (tree_type,
4543                                 ffecom_expr (arg1)),
4544                        convert (tree_type,
4545                                 ffecom_expr (arg2)));
4546
4547     case FFEINTRIN_impIOR:
4548     case FFEINTRIN_impOR:
4549       return ffecom_2 (BIT_IOR_EXPR, tree_type,
4550                        convert (tree_type,
4551                                 ffecom_expr (arg1)),
4552                        convert (tree_type,
4553                                 ffecom_expr (arg2)));
4554
4555     case FFEINTRIN_impIEOR:
4556     case FFEINTRIN_impXOR:
4557       return ffecom_2 (BIT_XOR_EXPR, tree_type,
4558                        convert (tree_type,
4559                                 ffecom_expr (arg1)),
4560                        convert (tree_type,
4561                                 ffecom_expr (arg2)));
4562
4563     case FFEINTRIN_impLSHIFT:
4564       return ffecom_2 (LSHIFT_EXPR, tree_type,
4565                        ffecom_expr (arg1),
4566                        convert (integer_type_node,
4567                                 ffecom_expr (arg2)));
4568
4569     case FFEINTRIN_impRSHIFT:
4570       return ffecom_2 (RSHIFT_EXPR, tree_type,
4571                        ffecom_expr (arg1),
4572                        convert (integer_type_node,
4573                                 ffecom_expr (arg2)));
4574
4575     case FFEINTRIN_impNOT:
4576       return ffecom_1 (BIT_NOT_EXPR, tree_type, ffecom_expr (arg1));
4577
4578     case FFEINTRIN_impBIT_SIZE:
4579       return convert (tree_type, TYPE_SIZE (arg1_type));
4580
4581     case FFEINTRIN_impBTEST:
4582       {
4583         ffetargetLogical1 true;
4584         ffetargetLogical1 false;
4585         tree true_tree;
4586         tree false_tree;
4587
4588         ffetarget_logical1 (&true, TRUE);
4589         ffetarget_logical1 (&false, FALSE);
4590         if (true == 1)
4591           true_tree = convert (tree_type, integer_one_node);
4592         else
4593           true_tree = convert (tree_type, build_int_2 (true, 0));
4594         if (false == 0)
4595           false_tree = convert (tree_type, integer_zero_node);
4596         else
4597           false_tree = convert (tree_type, build_int_2 (false, 0));
4598
4599         return
4600           ffecom_3 (COND_EXPR, tree_type,
4601                     ffecom_truth_value
4602                     (ffecom_2 (EQ_EXPR, integer_type_node,
4603                                ffecom_2 (BIT_AND_EXPR, arg1_type,
4604                                          ffecom_expr (arg1),
4605                                          ffecom_2 (LSHIFT_EXPR, arg1_type,
4606                                                    convert (arg1_type,
4607                                                           integer_one_node),
4608                                                    convert (integer_type_node,
4609                                                             ffecom_expr (arg2)))),
4610                                convert (arg1_type,
4611                                         integer_zero_node))),
4612                     false_tree,
4613                     true_tree);
4614       }
4615
4616     case FFEINTRIN_impIBCLR:
4617       return
4618         ffecom_2 (BIT_AND_EXPR, tree_type,
4619                   ffecom_expr (arg1),
4620                   ffecom_1 (BIT_NOT_EXPR, tree_type,
4621                             ffecom_2 (LSHIFT_EXPR, tree_type,
4622                                       convert (tree_type,
4623                                                integer_one_node),
4624                                       convert (integer_type_node,
4625                                                ffecom_expr (arg2)))));
4626
4627     case FFEINTRIN_impIBITS:
4628       {
4629         tree arg3_tree = ffecom_save_tree (convert (integer_type_node,
4630                                                     ffecom_expr (arg3)));
4631         tree uns_type
4632         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4633
4634         expr_tree
4635           = ffecom_2 (BIT_AND_EXPR, tree_type,
4636                       ffecom_2 (RSHIFT_EXPR, tree_type,
4637                                 ffecom_expr (arg1),
4638                                 convert (integer_type_node,
4639                                          ffecom_expr (arg2))),
4640                       convert (tree_type,
4641                                ffecom_2 (RSHIFT_EXPR, uns_type,
4642                                          ffecom_1 (BIT_NOT_EXPR,
4643                                                    uns_type,
4644                                                    convert (uns_type,
4645                                                         integer_zero_node)),
4646                                          ffecom_2 (MINUS_EXPR,
4647                                                    integer_type_node,
4648                                                    TYPE_SIZE (uns_type),
4649                                                    arg3_tree))));
4650 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4651         expr_tree
4652           = ffecom_3 (COND_EXPR, tree_type,
4653                       ffecom_truth_value
4654                       (ffecom_2 (NE_EXPR, integer_type_node,
4655                                  arg3_tree,
4656                                  integer_zero_node)),
4657                       expr_tree,
4658                       convert (tree_type, integer_zero_node));
4659 #endif
4660       }
4661       return expr_tree;
4662
4663     case FFEINTRIN_impIBSET:
4664       return
4665         ffecom_2 (BIT_IOR_EXPR, tree_type,
4666                   ffecom_expr (arg1),
4667                   ffecom_2 (LSHIFT_EXPR, tree_type,
4668                             convert (tree_type, integer_one_node),
4669                             convert (integer_type_node,
4670                                      ffecom_expr (arg2))));
4671
4672     case FFEINTRIN_impISHFT:
4673       {
4674         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4675         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4676                                                     ffecom_expr (arg2)));
4677         tree uns_type
4678         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4679
4680         expr_tree
4681           = ffecom_3 (COND_EXPR, tree_type,
4682                       ffecom_truth_value
4683                       (ffecom_2 (GE_EXPR, integer_type_node,
4684                                  arg2_tree,
4685                                  integer_zero_node)),
4686                       ffecom_2 (LSHIFT_EXPR, tree_type,
4687                                 arg1_tree,
4688                                 arg2_tree),
4689                       convert (tree_type,
4690                                ffecom_2 (RSHIFT_EXPR, uns_type,
4691                                          convert (uns_type, arg1_tree),
4692                                          ffecom_1 (NEGATE_EXPR,
4693                                                    integer_type_node,
4694                                                    arg2_tree))));
4695 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4696         expr_tree
4697           = ffecom_3 (COND_EXPR, tree_type,
4698                       ffecom_truth_value
4699                       (ffecom_2 (NE_EXPR, integer_type_node,
4700                                  arg2_tree,
4701                                  TYPE_SIZE (uns_type))),
4702                       expr_tree,
4703                       convert (tree_type, integer_zero_node));
4704 #endif
4705         /* Make sure SAVE_EXPRs get referenced early enough. */
4706         expr_tree
4707           = ffecom_2 (COMPOUND_EXPR, tree_type,
4708                       convert (void_type_node, arg1_tree),
4709                       ffecom_2 (COMPOUND_EXPR, tree_type,
4710                                 convert (void_type_node, arg2_tree),
4711                                 expr_tree));
4712       }
4713       return expr_tree;
4714
4715     case FFEINTRIN_impISHFTC:
4716       {
4717         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4718         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4719                                                     ffecom_expr (arg2)));
4720         tree arg3_tree = (arg3 == NULL) ? TYPE_SIZE (tree_type)
4721         : ffecom_save_tree (convert (integer_type_node, ffecom_expr (arg3)));
4722         tree shift_neg;
4723         tree shift_pos;
4724         tree mask_arg1;
4725         tree masked_arg1;
4726         tree uns_type
4727         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4728
4729         mask_arg1
4730           = ffecom_2 (LSHIFT_EXPR, tree_type,
4731                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4732                                 convert (tree_type, integer_zero_node)),
4733                       arg3_tree);
4734 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4735         mask_arg1
4736           = ffecom_3 (COND_EXPR, tree_type,
4737                       ffecom_truth_value
4738                       (ffecom_2 (NE_EXPR, integer_type_node,
4739                                  arg3_tree,
4740                                  TYPE_SIZE (uns_type))),
4741                       mask_arg1,
4742                       convert (tree_type, integer_zero_node));
4743 #endif
4744         mask_arg1 = ffecom_save_tree (mask_arg1);
4745         masked_arg1
4746           = ffecom_2 (BIT_AND_EXPR, tree_type,
4747                       arg1_tree,
4748                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4749                                 mask_arg1));
4750         masked_arg1 = ffecom_save_tree (masked_arg1);
4751         shift_neg
4752           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4753                       convert (tree_type,
4754                                ffecom_2 (RSHIFT_EXPR, uns_type,
4755                                          convert (uns_type, masked_arg1),
4756                                          ffecom_1 (NEGATE_EXPR,
4757                                                    integer_type_node,
4758                                                    arg2_tree))),
4759                       ffecom_2 (LSHIFT_EXPR, tree_type,
4760                                 arg1_tree,
4761                                 ffecom_2 (PLUS_EXPR, integer_type_node,
4762                                           arg2_tree,
4763                                           arg3_tree)));
4764         shift_pos
4765           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4766                       ffecom_2 (LSHIFT_EXPR, tree_type,
4767                                 arg1_tree,
4768                                 arg2_tree),
4769                       convert (tree_type,
4770                                ffecom_2 (RSHIFT_EXPR, uns_type,
4771                                          convert (uns_type, masked_arg1),
4772                                          ffecom_2 (MINUS_EXPR,
4773                                                    integer_type_node,
4774                                                    arg3_tree,
4775                                                    arg2_tree))));
4776         expr_tree
4777           = ffecom_3 (COND_EXPR, tree_type,
4778                       ffecom_truth_value
4779                       (ffecom_2 (LT_EXPR, integer_type_node,
4780                                  arg2_tree,
4781                                  integer_zero_node)),
4782                       shift_neg,
4783                       shift_pos);
4784         expr_tree
4785           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4786                       ffecom_2 (BIT_AND_EXPR, tree_type,
4787                                 mask_arg1,
4788                                 arg1_tree),
4789                       ffecom_2 (BIT_AND_EXPR, tree_type,
4790                                 ffecom_1 (BIT_NOT_EXPR, tree_type,
4791                                           mask_arg1),
4792                                 expr_tree));
4793         expr_tree
4794           = ffecom_3 (COND_EXPR, tree_type,
4795                       ffecom_truth_value
4796                       (ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
4797                                  ffecom_2 (EQ_EXPR, integer_type_node,
4798                                            ffecom_1 (ABS_EXPR,
4799                                                      integer_type_node,
4800                                                      arg2_tree),
4801                                            arg3_tree),
4802                                  ffecom_2 (EQ_EXPR, integer_type_node,
4803                                            arg2_tree,
4804                                            integer_zero_node))),
4805                       arg1_tree,
4806                       expr_tree);
4807         /* Make sure SAVE_EXPRs get referenced early enough. */
4808         expr_tree
4809           = ffecom_2 (COMPOUND_EXPR, tree_type,
4810                       convert (void_type_node, arg1_tree),
4811                       ffecom_2 (COMPOUND_EXPR, tree_type,
4812                                 convert (void_type_node, arg2_tree),
4813                                 ffecom_2 (COMPOUND_EXPR, tree_type,
4814                                           convert (void_type_node,
4815                                                    mask_arg1),
4816                                           ffecom_2 (COMPOUND_EXPR, tree_type,
4817                                                     convert (void_type_node,
4818                                                              masked_arg1),
4819                                                     expr_tree))));
4820         expr_tree
4821           = ffecom_2 (COMPOUND_EXPR, tree_type,
4822                       convert (void_type_node,
4823                                arg3_tree),
4824                       expr_tree);
4825       }
4826       return expr_tree;
4827
4828     case FFEINTRIN_impLOC:
4829       {
4830         tree arg1_tree = ffecom_expr (arg1);
4831
4832         expr_tree
4833           = convert (tree_type,
4834                      ffecom_1 (ADDR_EXPR,
4835                                build_pointer_type (TREE_TYPE (arg1_tree)),
4836                                arg1_tree));
4837       }
4838       return expr_tree;
4839
4840     case FFEINTRIN_impMVBITS:
4841       {
4842         tree arg1_tree;
4843         tree arg2_tree;
4844         tree arg3_tree;
4845         ffebld arg4 = ffebld_head (ffebld_trail (list));
4846         tree arg4_tree;
4847         tree arg4_type;
4848         ffebld arg5 = ffebld_head (ffebld_trail (ffebld_trail (list)));
4849         tree arg5_tree;
4850         tree prep_arg1;
4851         tree prep_arg4;
4852         tree arg5_plus_arg3;
4853
4854         arg2_tree = convert (integer_type_node,
4855                              ffecom_expr (arg2));
4856         arg3_tree = ffecom_save_tree (convert (integer_type_node,
4857                                                ffecom_expr (arg3)));
4858         arg4_tree = ffecom_expr_rw (NULL_TREE, arg4);
4859         arg4_type = TREE_TYPE (arg4_tree);
4860
4861         arg1_tree = ffecom_save_tree (convert (arg4_type,
4862                                                ffecom_expr (arg1)));
4863
4864         arg5_tree = ffecom_save_tree (convert (integer_type_node,
4865                                                ffecom_expr (arg5)));
4866
4867         prep_arg1
4868           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4869                       ffecom_2 (BIT_AND_EXPR, arg4_type,
4870                                 ffecom_2 (RSHIFT_EXPR, arg4_type,
4871                                           arg1_tree,
4872                                           arg2_tree),
4873                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4874                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4875                                                     ffecom_1 (BIT_NOT_EXPR,
4876                                                               arg4_type,
4877                                                               convert
4878                                                               (arg4_type,
4879                                                         integer_zero_node)),
4880                                                     arg3_tree))),
4881                       arg5_tree);
4882         arg5_plus_arg3
4883           = ffecom_save_tree (ffecom_2 (PLUS_EXPR, arg4_type,
4884                                         arg5_tree,
4885                                         arg3_tree));
4886         prep_arg4
4887           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4888                       ffecom_1 (BIT_NOT_EXPR, arg4_type,
4889                                 convert (arg4_type,
4890                                          integer_zero_node)),
4891                       arg5_plus_arg3);
4892 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4893         prep_arg4
4894           = ffecom_3 (COND_EXPR, arg4_type,
4895                       ffecom_truth_value
4896                       (ffecom_2 (NE_EXPR, integer_type_node,
4897                                  arg5_plus_arg3,
4898                                  convert (TREE_TYPE (arg5_plus_arg3),
4899                                           TYPE_SIZE (arg4_type)))),
4900                       prep_arg4,
4901                       convert (arg4_type, integer_zero_node));
4902 #endif
4903         prep_arg4
4904           = ffecom_2 (BIT_AND_EXPR, arg4_type,
4905                       arg4_tree,
4906                       ffecom_2 (BIT_IOR_EXPR, arg4_type,
4907                                 prep_arg4,
4908                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4909                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4910                                                     ffecom_1 (BIT_NOT_EXPR,
4911                                                               arg4_type,
4912                                                               convert
4913                                                               (arg4_type,
4914                                                         integer_zero_node)),
4915                                                     arg5_tree))));
4916         prep_arg1
4917           = ffecom_2 (BIT_IOR_EXPR, arg4_type,
4918                       prep_arg1,
4919                       prep_arg4);
4920 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4921         prep_arg1
4922           = ffecom_3 (COND_EXPR, arg4_type,
4923                       ffecom_truth_value
4924                       (ffecom_2 (NE_EXPR, integer_type_node,
4925                                  arg3_tree,
4926                                  convert (TREE_TYPE (arg3_tree),
4927                                           integer_zero_node))),
4928                       prep_arg1,
4929                       arg4_tree);
4930         prep_arg1
4931           = ffecom_3 (COND_EXPR, arg4_type,
4932                       ffecom_truth_value
4933                       (ffecom_2 (NE_EXPR, integer_type_node,
4934                                  arg3_tree,
4935                                  convert (TREE_TYPE (arg3_tree),
4936                                           TYPE_SIZE (arg4_type)))),
4937                       prep_arg1,
4938                       arg1_tree);
4939 #endif
4940         expr_tree
4941           = ffecom_2s (MODIFY_EXPR, void_type_node,
4942                        arg4_tree,
4943                        prep_arg1);
4944         /* Make sure SAVE_EXPRs get referenced early enough. */
4945         expr_tree
4946           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4947                       arg1_tree,
4948                       ffecom_2 (COMPOUND_EXPR, void_type_node,
4949                                 arg3_tree,
4950                                 ffecom_2 (COMPOUND_EXPR, void_type_node,
4951                                           arg5_tree,
4952                                           ffecom_2 (COMPOUND_EXPR, void_type_node,
4953                                                     arg5_plus_arg3,
4954                                                     expr_tree))));
4955         expr_tree
4956           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4957                       arg4_tree,
4958                       expr_tree);
4959
4960       }
4961       return expr_tree;
4962
4963     case FFEINTRIN_impDERF:
4964     case FFEINTRIN_impERF:
4965     case FFEINTRIN_impDERFC:
4966     case FFEINTRIN_impERFC:
4967       break;
4968
4969     case FFEINTRIN_impIARGC:
4970       /* extern int xargc; i__1 = xargc - 1; */
4971       expr_tree = ffecom_2 (MINUS_EXPR, TREE_TYPE (ffecom_tree_xargc_),
4972                             ffecom_tree_xargc_,
4973                             convert (TREE_TYPE (ffecom_tree_xargc_),
4974                                      integer_one_node));
4975       return expr_tree;
4976
4977     case FFEINTRIN_impSIGNAL_func:
4978     case FFEINTRIN_impSIGNAL_subr:
4979       {
4980         tree arg1_tree;
4981         tree arg2_tree;
4982         tree arg3_tree;
4983
4984         arg1_tree = convert (ffecom_f2c_integer_type_node,
4985                              ffecom_expr (arg1));
4986         arg1_tree = ffecom_1 (ADDR_EXPR,
4987                               build_pointer_type (TREE_TYPE (arg1_tree)),
4988                               arg1_tree);
4989
4990         /* Pass procedure as a pointer to it, anything else by value.  */
4991         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4992           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4993         else
4994           arg2_tree = ffecom_ptr_to_expr (arg2);
4995         arg2_tree = convert (TREE_TYPE (null_pointer_node),
4996                              arg2_tree);
4997
4998         if (arg3 != NULL)
4999           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5000         else
5001           arg3_tree = NULL_TREE;
5002
5003         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5004         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5005         TREE_CHAIN (arg1_tree) = arg2_tree;
5006
5007         expr_tree
5008           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5009                           ffecom_gfrt_kindtype (gfrt),
5010                           FALSE,
5011                           ((codegen_imp == FFEINTRIN_impSIGNAL_subr) ?
5012                            NULL_TREE :
5013                            tree_type),
5014                           arg1_tree,
5015                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5016                           ffebld_nonter_hook (expr));
5017
5018         if (arg3_tree != NULL_TREE)
5019           expr_tree
5020             = ffecom_modify (NULL_TREE, arg3_tree,
5021                              convert (TREE_TYPE (arg3_tree),
5022                                       expr_tree));
5023       }
5024       return expr_tree;
5025
5026     case FFEINTRIN_impALARM:
5027       {
5028         tree arg1_tree;
5029         tree arg2_tree;
5030         tree arg3_tree;
5031
5032         arg1_tree = convert (ffecom_f2c_integer_type_node,
5033                              ffecom_expr (arg1));
5034         arg1_tree = ffecom_1 (ADDR_EXPR,
5035                               build_pointer_type (TREE_TYPE (arg1_tree)),
5036                               arg1_tree);
5037
5038         /* Pass procedure as a pointer to it, anything else by value.  */
5039         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
5040           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
5041         else
5042           arg2_tree = ffecom_ptr_to_expr (arg2);
5043         arg2_tree = convert (TREE_TYPE (null_pointer_node),
5044                              arg2_tree);
5045
5046         if (arg3 != NULL)
5047           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5048         else
5049           arg3_tree = NULL_TREE;
5050
5051         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5052         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5053         TREE_CHAIN (arg1_tree) = arg2_tree;
5054
5055         expr_tree
5056           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5057                           ffecom_gfrt_kindtype (gfrt),
5058                           FALSE,
5059                           NULL_TREE,
5060                           arg1_tree,
5061                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5062                           ffebld_nonter_hook (expr));
5063
5064         if (arg3_tree != NULL_TREE)
5065           expr_tree
5066             = ffecom_modify (NULL_TREE, arg3_tree,
5067                              convert (TREE_TYPE (arg3_tree),
5068                                       expr_tree));
5069       }
5070       return expr_tree;
5071
5072     case FFEINTRIN_impCHDIR_subr:
5073     case FFEINTRIN_impFDATE_subr:
5074     case FFEINTRIN_impFGET_subr:
5075     case FFEINTRIN_impFPUT_subr:
5076     case FFEINTRIN_impGETCWD_subr:
5077     case FFEINTRIN_impHOSTNM_subr:
5078     case FFEINTRIN_impSYSTEM_subr:
5079     case FFEINTRIN_impUNLINK_subr:
5080       {
5081         tree arg1_len = integer_zero_node;
5082         tree arg1_tree;
5083         tree arg2_tree;
5084
5085         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5086
5087         if (arg2 != NULL)
5088           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
5089         else
5090           arg2_tree = NULL_TREE;
5091
5092         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5093         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5094         TREE_CHAIN (arg1_tree) = arg1_len;
5095
5096         expr_tree
5097           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5098                           ffecom_gfrt_kindtype (gfrt),
5099                           FALSE,
5100                           NULL_TREE,
5101                           arg1_tree,
5102                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5103                           ffebld_nonter_hook (expr));
5104
5105         if (arg2_tree != NULL_TREE)
5106           expr_tree
5107             = ffecom_modify (NULL_TREE, arg2_tree,
5108                              convert (TREE_TYPE (arg2_tree),
5109                                       expr_tree));
5110       }
5111       return expr_tree;
5112
5113     case FFEINTRIN_impEXIT:
5114       if (arg1 != NULL)
5115         break;
5116
5117       expr_tree = build_tree_list (NULL_TREE,
5118                                    ffecom_1 (ADDR_EXPR,
5119                                              build_pointer_type
5120                                              (ffecom_integer_type_node),
5121                                              integer_zero_node));
5122
5123       return
5124         ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5125                       ffecom_gfrt_kindtype (gfrt),
5126                       FALSE,
5127                       void_type_node,
5128                       expr_tree,
5129                       NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5130                       ffebld_nonter_hook (expr));
5131
5132     case FFEINTRIN_impFLUSH:
5133       if (arg1 == NULL)
5134         gfrt = FFECOM_gfrtFLUSH;
5135       else
5136         gfrt = FFECOM_gfrtFLUSH1;
5137       break;
5138
5139     case FFEINTRIN_impCHMOD_subr:
5140     case FFEINTRIN_impLINK_subr:
5141     case FFEINTRIN_impRENAME_subr:
5142     case FFEINTRIN_impSYMLNK_subr:
5143       {
5144         tree arg1_len = integer_zero_node;
5145         tree arg1_tree;
5146         tree arg2_len = integer_zero_node;
5147         tree arg2_tree;
5148         tree arg3_tree;
5149
5150         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5151         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
5152         if (arg3 != NULL)
5153           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5154         else
5155           arg3_tree = NULL_TREE;
5156
5157         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5158         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5159         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5160         arg2_len = build_tree_list (NULL_TREE, arg2_len);
5161         TREE_CHAIN (arg1_tree) = arg2_tree;
5162         TREE_CHAIN (arg2_tree) = arg1_len;
5163         TREE_CHAIN (arg1_len) = arg2_len;
5164         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5165                                   ffecom_gfrt_kindtype (gfrt),
5166                                   FALSE,
5167                                   NULL_TREE,
5168                                   arg1_tree,
5169                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5170                                   ffebld_nonter_hook (expr));
5171         if (arg3_tree != NULL_TREE)
5172           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5173                                      convert (TREE_TYPE (arg3_tree),
5174                                               expr_tree));
5175       }
5176       return expr_tree;
5177
5178     case FFEINTRIN_impLSTAT_subr:
5179     case FFEINTRIN_impSTAT_subr:
5180       {
5181         tree arg1_len = integer_zero_node;
5182         tree arg1_tree;
5183         tree arg2_tree;
5184         tree arg3_tree;
5185
5186         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5187
5188         arg2_tree = ffecom_ptr_to_expr (arg2);
5189
5190         if (arg3 != NULL)
5191           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5192         else
5193           arg3_tree = NULL_TREE;
5194
5195         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5196         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5197         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5198         TREE_CHAIN (arg1_tree) = arg2_tree;
5199         TREE_CHAIN (arg2_tree) = arg1_len;
5200         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5201                                   ffecom_gfrt_kindtype (gfrt),
5202                                   FALSE,
5203                                   NULL_TREE,
5204                                   arg1_tree,
5205                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5206                                   ffebld_nonter_hook (expr));
5207         if (arg3_tree != NULL_TREE)
5208           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5209                                      convert (TREE_TYPE (arg3_tree),
5210                                               expr_tree));
5211       }
5212       return expr_tree;
5213
5214     case FFEINTRIN_impFGETC_subr:
5215     case FFEINTRIN_impFPUTC_subr:
5216       {
5217         tree arg1_tree;
5218         tree arg2_tree;
5219         tree arg2_len = integer_zero_node;
5220         tree arg3_tree;
5221
5222         arg1_tree = convert (ffecom_f2c_integer_type_node,
5223                              ffecom_expr (arg1));
5224         arg1_tree = ffecom_1 (ADDR_EXPR,
5225                               build_pointer_type (TREE_TYPE (arg1_tree)),
5226                               arg1_tree);
5227
5228         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
5229         arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5230
5231         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5232         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5233         arg2_len = build_tree_list (NULL_TREE, arg2_len);
5234         TREE_CHAIN (arg1_tree) = arg2_tree;
5235         TREE_CHAIN (arg2_tree) = arg2_len;
5236
5237         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5238                                   ffecom_gfrt_kindtype (gfrt),
5239                                   FALSE,
5240                                   NULL_TREE,
5241                                   arg1_tree,
5242                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5243                                   ffebld_nonter_hook (expr));
5244         expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5245                                    convert (TREE_TYPE (arg3_tree),
5246                                             expr_tree));
5247       }
5248       return expr_tree;
5249
5250     case FFEINTRIN_impFSTAT_subr:
5251       {
5252         tree arg1_tree;
5253         tree arg2_tree;
5254         tree arg3_tree;
5255
5256         arg1_tree = convert (ffecom_f2c_integer_type_node,
5257                              ffecom_expr (arg1));
5258         arg1_tree = ffecom_1 (ADDR_EXPR,
5259                               build_pointer_type (TREE_TYPE (arg1_tree)),
5260                               arg1_tree);
5261
5262         arg2_tree = convert (ffecom_f2c_ptr_to_integer_type_node,
5263                              ffecom_ptr_to_expr (arg2));
5264
5265         if (arg3 == NULL)
5266           arg3_tree = NULL_TREE;
5267         else
5268           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5269
5270         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5271         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5272         TREE_CHAIN (arg1_tree) = arg2_tree;
5273         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5274                                   ffecom_gfrt_kindtype (gfrt),
5275                                   FALSE,
5276                                   NULL_TREE,
5277                                   arg1_tree,
5278                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5279                                   ffebld_nonter_hook (expr));
5280         if (arg3_tree != NULL_TREE) {
5281           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5282                                      convert (TREE_TYPE (arg3_tree),
5283                                               expr_tree));
5284         }
5285       }
5286       return expr_tree;
5287
5288     case FFEINTRIN_impKILL_subr:
5289       {
5290         tree arg1_tree;
5291         tree arg2_tree;
5292         tree arg3_tree;
5293
5294         arg1_tree = convert (ffecom_f2c_integer_type_node,
5295                              ffecom_expr (arg1));
5296         arg1_tree = ffecom_1 (ADDR_EXPR,
5297                               build_pointer_type (TREE_TYPE (arg1_tree)),
5298                               arg1_tree);
5299
5300         arg2_tree = convert (ffecom_f2c_integer_type_node,
5301                              ffecom_expr (arg2));
5302         arg2_tree = ffecom_1 (ADDR_EXPR,
5303                               build_pointer_type (TREE_TYPE (arg2_tree)),
5304                               arg2_tree);
5305
5306         if (arg3 == NULL)
5307           arg3_tree = NULL_TREE;
5308         else
5309           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5310
5311         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5312         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5313         TREE_CHAIN (arg1_tree) = arg2_tree;
5314         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5315                                   ffecom_gfrt_kindtype (gfrt),
5316                                   FALSE,
5317                                   NULL_TREE,
5318                                   arg1_tree,
5319                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5320                                   ffebld_nonter_hook (expr));
5321         if (arg3_tree != NULL_TREE) {
5322           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5323                                      convert (TREE_TYPE (arg3_tree),
5324                                               expr_tree));
5325         }
5326       }
5327       return expr_tree;
5328
5329     case FFEINTRIN_impCTIME_subr:
5330     case FFEINTRIN_impTTYNAM_subr:
5331       {
5332         tree arg1_len = integer_zero_node;
5333         tree arg1_tree;
5334         tree arg2_tree;
5335
5336         arg1_tree = ffecom_arg_ptr_to_expr (arg2, &arg1_len);
5337
5338         arg2_tree = convert (((codegen_imp == FFEINTRIN_impCTIME_subr) ?
5339                               ffecom_f2c_longint_type_node :
5340                               ffecom_f2c_integer_type_node),
5341                              ffecom_expr (arg1));
5342         arg2_tree = ffecom_1 (ADDR_EXPR,
5343                               build_pointer_type (TREE_TYPE (arg2_tree)),
5344                               arg2_tree);
5345
5346         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5347         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5348         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5349         TREE_CHAIN (arg1_len) = arg2_tree;
5350         TREE_CHAIN (arg1_tree) = arg1_len;
5351
5352         expr_tree
5353           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5354                           ffecom_gfrt_kindtype (gfrt),
5355                           FALSE,
5356                           NULL_TREE,
5357                           arg1_tree,
5358                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5359                           ffebld_nonter_hook (expr));
5360         TREE_SIDE_EFFECTS (expr_tree) = 1;
5361       }
5362       return expr_tree;
5363
5364     case FFEINTRIN_impIRAND:
5365     case FFEINTRIN_impRAND:
5366       /* Arg defaults to 0 (normal random case) */
5367       {
5368         tree arg1_tree;
5369
5370         if (arg1 == NULL)
5371           arg1_tree = ffecom_integer_zero_node;
5372         else
5373           arg1_tree = ffecom_expr (arg1);
5374         arg1_tree = convert (ffecom_f2c_integer_type_node,
5375                              arg1_tree);
5376         arg1_tree = ffecom_1 (ADDR_EXPR,
5377                               build_pointer_type (TREE_TYPE (arg1_tree)),
5378                               arg1_tree);
5379         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5380
5381         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5382                                   ffecom_gfrt_kindtype (gfrt),
5383                                   FALSE,
5384                                   ((codegen_imp == FFEINTRIN_impIRAND) ?
5385                                    ffecom_f2c_integer_type_node :
5386                                    ffecom_f2c_real_type_node),
5387                                   arg1_tree,
5388                                   dest_tree, dest, dest_used,
5389                                   NULL_TREE, TRUE,
5390                                   ffebld_nonter_hook (expr));
5391       }
5392       return expr_tree;
5393
5394     case FFEINTRIN_impFTELL_subr:
5395     case FFEINTRIN_impUMASK_subr:
5396       {
5397         tree arg1_tree;
5398         tree arg2_tree;
5399
5400         arg1_tree = convert (ffecom_f2c_integer_type_node,
5401                              ffecom_expr (arg1));
5402         arg1_tree = ffecom_1 (ADDR_EXPR,
5403                               build_pointer_type (TREE_TYPE (arg1_tree)),
5404                               arg1_tree);
5405
5406         if (arg2 == NULL)
5407           arg2_tree = NULL_TREE;
5408         else
5409           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
5410
5411         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5412                                   ffecom_gfrt_kindtype (gfrt),
5413                                   FALSE,
5414                                   NULL_TREE,
5415                                   build_tree_list (NULL_TREE, arg1_tree),
5416                                   NULL_TREE, NULL, NULL, NULL_TREE,
5417                                   TRUE,
5418                                   ffebld_nonter_hook (expr));
5419         if (arg2_tree != NULL_TREE) {
5420           expr_tree = ffecom_modify (NULL_TREE, arg2_tree,
5421                                      convert (TREE_TYPE (arg2_tree),
5422                                               expr_tree));
5423         }
5424       }
5425       return expr_tree;
5426
5427     case FFEINTRIN_impCPU_TIME:
5428     case FFEINTRIN_impSECOND_subr:
5429       {
5430         tree arg1_tree;
5431
5432         arg1_tree = ffecom_expr_w (NULL_TREE, arg1);
5433
5434         expr_tree
5435           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5436                           ffecom_gfrt_kindtype (gfrt),
5437                           FALSE,
5438                           NULL_TREE,
5439                           NULL_TREE,
5440                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5441                           ffebld_nonter_hook (expr));
5442
5443         expr_tree
5444           = ffecom_modify (NULL_TREE, arg1_tree,
5445                            convert (TREE_TYPE (arg1_tree),
5446                                     expr_tree));
5447       }
5448       return expr_tree;
5449
5450     case FFEINTRIN_impDTIME_subr:
5451     case FFEINTRIN_impETIME_subr:
5452       {
5453         tree arg1_tree;
5454         tree result_tree;
5455
5456         result_tree = ffecom_expr_w (NULL_TREE, arg2);
5457
5458         arg1_tree = ffecom_ptr_to_expr (arg1);
5459
5460         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5461                                   ffecom_gfrt_kindtype (gfrt),
5462                                   FALSE,
5463                                   NULL_TREE,
5464                                   build_tree_list (NULL_TREE, arg1_tree),
5465                                   NULL_TREE, NULL, NULL, NULL_TREE,
5466                                   TRUE,
5467                                   ffebld_nonter_hook (expr));
5468         expr_tree = ffecom_modify (NULL_TREE, result_tree,
5469                                    convert (TREE_TYPE (result_tree),
5470                                             expr_tree));
5471       }
5472       return expr_tree;
5473
5474       /* Straightforward calls of libf2c routines: */
5475     case FFEINTRIN_impABORT:
5476     case FFEINTRIN_impACCESS:
5477     case FFEINTRIN_impBESJ0:
5478     case FFEINTRIN_impBESJ1:
5479     case FFEINTRIN_impBESJN:
5480     case FFEINTRIN_impBESY0:
5481     case FFEINTRIN_impBESY1:
5482     case FFEINTRIN_impBESYN:
5483     case FFEINTRIN_impCHDIR_func:
5484     case FFEINTRIN_impCHMOD_func:
5485     case FFEINTRIN_impDATE:
5486     case FFEINTRIN_impDATE_AND_TIME:
5487     case FFEINTRIN_impDBESJ0:
5488     case FFEINTRIN_impDBESJ1:
5489     case FFEINTRIN_impDBESJN:
5490     case FFEINTRIN_impDBESY0:
5491     case FFEINTRIN_impDBESY1:
5492     case FFEINTRIN_impDBESYN:
5493     case FFEINTRIN_impDTIME_func:
5494     case FFEINTRIN_impETIME_func:
5495     case FFEINTRIN_impFGETC_func:
5496     case FFEINTRIN_impFGET_func:
5497     case FFEINTRIN_impFNUM:
5498     case FFEINTRIN_impFPUTC_func:
5499     case FFEINTRIN_impFPUT_func:
5500     case FFEINTRIN_impFSEEK:
5501     case FFEINTRIN_impFSTAT_func:
5502     case FFEINTRIN_impFTELL_func:
5503     case FFEINTRIN_impGERROR:
5504     case FFEINTRIN_impGETARG:
5505     case FFEINTRIN_impGETCWD_func:
5506     case FFEINTRIN_impGETENV:
5507     case FFEINTRIN_impGETGID:
5508     case FFEINTRIN_impGETLOG:
5509     case FFEINTRIN_impGETPID:
5510     case FFEINTRIN_impGETUID:
5511     case FFEINTRIN_impGMTIME:
5512     case FFEINTRIN_impHOSTNM_func:
5513     case FFEINTRIN_impIDATE_unix:
5514     case FFEINTRIN_impIDATE_vxt:
5515     case FFEINTRIN_impIERRNO:
5516     case FFEINTRIN_impISATTY:
5517     case FFEINTRIN_impITIME:
5518     case FFEINTRIN_impKILL_func:
5519     case FFEINTRIN_impLINK_func:
5520     case FFEINTRIN_impLNBLNK:
5521     case FFEINTRIN_impLSTAT_func:
5522     case FFEINTRIN_impLTIME:
5523     case FFEINTRIN_impMCLOCK8:
5524     case FFEINTRIN_impMCLOCK:
5525     case FFEINTRIN_impPERROR:
5526     case FFEINTRIN_impRENAME_func:
5527     case FFEINTRIN_impSECNDS:
5528     case FFEINTRIN_impSECOND_func:
5529     case FFEINTRIN_impSLEEP:
5530     case FFEINTRIN_impSRAND:
5531     case FFEINTRIN_impSTAT_func:
5532     case FFEINTRIN_impSYMLNK_func:
5533     case FFEINTRIN_impSYSTEM_CLOCK:
5534     case FFEINTRIN_impSYSTEM_func:
5535     case FFEINTRIN_impTIME8:
5536     case FFEINTRIN_impTIME_unix:
5537     case FFEINTRIN_impTIME_vxt:
5538     case FFEINTRIN_impUMASK_func:
5539     case FFEINTRIN_impUNLINK_func:
5540       break;
5541
5542     case FFEINTRIN_impCTIME_func:       /* CHARACTER functions not handled here. */
5543     case FFEINTRIN_impFDATE_func:       /* CHARACTER functions not handled here. */
5544     case FFEINTRIN_impTTYNAM_func:      /* CHARACTER functions not handled here. */
5545     case FFEINTRIN_impNONE:
5546     case FFEINTRIN_imp:         /* Hush up gcc warning. */
5547       fprintf (stderr, "No %s implementation.\n",
5548                ffeintrin_name_implementation (ffebld_symter_implementation (ffebld_left (expr))));
5549       assert ("unimplemented intrinsic" == NULL);
5550       return error_mark_node;
5551     }
5552
5553   assert (gfrt != FFECOM_gfrt); /* Must have an implementation! */
5554
5555   expr_tree = ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt),
5556                                     ffebld_right (expr));
5557
5558   return ffecom_call_ (ffecom_gfrt_tree_ (gfrt), ffecom_gfrt_kindtype (gfrt),
5559                        (ffe_is_f2c_library () && ffecom_gfrt_complex_[gfrt]),
5560                        tree_type,
5561                        expr_tree, dest_tree, dest, dest_used,
5562                        NULL_TREE, TRUE,
5563                        ffebld_nonter_hook (expr));
5564
5565   /* See bottom of this file for f2c transforms used to determine
5566      many of the above implementations.  The info seems to confuse
5567      Emacs's C mode indentation, which is why it's been moved to
5568      the bottom of this source file.  */
5569 }
5570
5571 #endif
5572 /* For power (exponentiation) where right-hand operand is type INTEGER,
5573    generate in-line code to do it the fast way (which, if the operand
5574    is a constant, might just mean a series of multiplies).  */
5575
5576 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5577 static tree
5578 ffecom_expr_power_integer_ (ffebld expr)
5579 {
5580   tree l = ffecom_expr (ffebld_left (expr));
5581   tree r = ffecom_expr (ffebld_right (expr));
5582   tree ltype = TREE_TYPE (l);
5583   tree rtype = TREE_TYPE (r);
5584   tree result = NULL_TREE;
5585
5586   if (l == error_mark_node
5587       || r == error_mark_node)
5588     return error_mark_node;
5589
5590   if (TREE_CODE (r) == INTEGER_CST)
5591     {
5592       int sgn = tree_int_cst_sgn (r);
5593
5594       if (sgn == 0)
5595         return convert (ltype, integer_one_node);
5596
5597       if ((TREE_CODE (ltype) == INTEGER_TYPE)
5598           && (sgn < 0))
5599         {
5600           /* Reciprocal of integer is either 0, -1, or 1, so after
5601              calculating that (which we leave to the back end to do
5602              or not do optimally), don't bother with any multiplying.  */
5603
5604           result = ffecom_tree_divide_ (ltype,
5605                                         convert (ltype, integer_one_node),
5606                                         l,
5607                                         NULL_TREE, NULL, NULL, NULL_TREE);
5608           r = ffecom_1 (NEGATE_EXPR,
5609                         rtype,
5610                         r);
5611           if ((TREE_INT_CST_LOW (r) & 1) == 0)
5612             result = ffecom_1 (ABS_EXPR, rtype,
5613                                result);
5614         }
5615
5616       /* Generate appropriate series of multiplies, preceded
5617          by divide if the exponent is negative.  */
5618
5619       l = save_expr (l);
5620
5621       if (sgn < 0)
5622         {
5623           l = ffecom_tree_divide_ (ltype,
5624                                    convert (ltype, integer_one_node),
5625                                    l,
5626                                    NULL_TREE, NULL, NULL,
5627                                    ffebld_nonter_hook (expr));
5628           r = ffecom_1 (NEGATE_EXPR, rtype, r);
5629           assert (TREE_CODE (r) == INTEGER_CST);
5630
5631           if (tree_int_cst_sgn (r) < 0)
5632             {                   /* The "most negative" number.  */
5633               r = ffecom_1 (NEGATE_EXPR, rtype,
5634                             ffecom_2 (RSHIFT_EXPR, rtype,
5635                                       r,
5636                                       integer_one_node));
5637               l = save_expr (l);
5638               l = ffecom_2 (MULT_EXPR, ltype,
5639                             l,
5640                             l);
5641             }
5642         }
5643
5644       for (;;)
5645         {
5646           if (TREE_INT_CST_LOW (r) & 1)
5647             {
5648               if (result == NULL_TREE)
5649                 result = l;
5650               else
5651                 result = ffecom_2 (MULT_EXPR, ltype,
5652                                    result,
5653                                    l);
5654             }
5655
5656           r = ffecom_2 (RSHIFT_EXPR, rtype,
5657                         r,
5658                         integer_one_node);
5659           if (integer_zerop (r))
5660             break;
5661           assert (TREE_CODE (r) == INTEGER_CST);
5662
5663           l = save_expr (l);
5664           l = ffecom_2 (MULT_EXPR, ltype,
5665                         l,
5666                         l);
5667         }
5668       return result;
5669     }
5670
5671   /* Though rhs isn't a constant, in-line code cannot be expanded
5672      while transforming dummies
5673      because the back end cannot be easily convinced to generate
5674      stores (MODIFY_EXPR), handle temporaries, and so on before
5675      all the appropriate rtx's have been generated for things like
5676      dummy args referenced in rhs -- which doesn't happen until
5677      store_parm_decls() is called (expand_function_start, I believe,
5678      does the actual rtx-stuffing of PARM_DECLs).
5679
5680      So, in this case, let the caller generate the call to the
5681      run-time-library function to evaluate the power for us.  */
5682
5683   if (ffecom_transform_only_dummies_)
5684     return NULL_TREE;
5685
5686   /* Right-hand operand not a constant, expand in-line code to figure
5687      out how to do the multiplies, &c.
5688
5689      The returned expression is expressed this way in GNU C, where l and
5690      r are the "inputs":
5691
5692      ({ typeof (r) rtmp = r;
5693         typeof (l) ltmp = l;
5694         typeof (l) result;
5695
5696         if (rtmp == 0)
5697           result = 1;
5698         else
5699           {
5700             if ((basetypeof (l) == basetypeof (int))
5701                 && (rtmp < 0))
5702               {
5703                 result = ((typeof (l)) 1) / ltmp;
5704                 if ((ltmp < 0) && (((-rtmp) & 1) == 0))
5705                   result = -result;
5706               }
5707             else
5708               {
5709                 result = 1;
5710                 if ((basetypeof (l) != basetypeof (int))
5711                     && (rtmp < 0))
5712                   {
5713                     ltmp = ((typeof (l)) 1) / ltmp;
5714                     rtmp = -rtmp;
5715                     if (rtmp < 0)
5716                       {
5717                         rtmp = -(rtmp >> 1);
5718                         ltmp *= ltmp;
5719                       }
5720                   }
5721                 for (;;)
5722                   {
5723                     if (rtmp & 1)
5724                       result *= ltmp;
5725                     if ((rtmp >>= 1) == 0)
5726                       break;
5727                     ltmp *= ltmp;
5728                   }
5729               }
5730           }
5731         result;
5732      })
5733
5734      Note that some of the above is compile-time collapsable, such as
5735      the first part of the if statements that checks the base type of
5736      l against int.  The if statements are phrased that way to suggest
5737      an easy way to generate the if/else constructs here, knowing that
5738      the back end should (and probably does) eliminate the resulting
5739      dead code (either the int case or the non-int case), something
5740      it couldn't do without the redundant phrasing, requiring explicit
5741      dead-code elimination here, which would be kind of difficult to
5742      read.  */
5743
5744   {
5745     tree rtmp;
5746     tree ltmp;
5747     tree divide;
5748     tree basetypeof_l_is_int;
5749     tree se;
5750     tree t;
5751
5752     basetypeof_l_is_int
5753       = build_int_2 ((TREE_CODE (ltype) == INTEGER_TYPE), 0);
5754
5755     se = expand_start_stmt_expr ();
5756
5757     ffecom_start_compstmt ();
5758
5759 #ifndef HAHA
5760     rtmp = ffecom_make_tempvar ("power_r", rtype,
5761                                 FFETARGET_charactersizeNONE, -1);
5762     ltmp = ffecom_make_tempvar ("power_l", ltype,
5763                                 FFETARGET_charactersizeNONE, -1);
5764     result = ffecom_make_tempvar ("power_res", ltype,
5765                                   FFETARGET_charactersizeNONE, -1);
5766     if (TREE_CODE (ltype) == COMPLEX_TYPE
5767         || TREE_CODE (ltype) == RECORD_TYPE)
5768       divide = ffecom_make_tempvar ("power_div", ltype,
5769                                     FFETARGET_charactersizeNONE, -1);
5770     else
5771       divide = NULL_TREE;
5772 #else  /* HAHA */
5773     {
5774       tree hook;
5775
5776       hook = ffebld_nonter_hook (expr);
5777       assert (hook);
5778       assert (TREE_CODE (hook) == TREE_VEC);
5779       assert (TREE_VEC_LENGTH (hook) == 4);
5780       rtmp = TREE_VEC_ELT (hook, 0);
5781       ltmp = TREE_VEC_ELT (hook, 1);
5782       result = TREE_VEC_ELT (hook, 2);
5783       divide = TREE_VEC_ELT (hook, 3);
5784       if (TREE_CODE (ltype) == COMPLEX_TYPE
5785           || TREE_CODE (ltype) == RECORD_TYPE)
5786         assert (divide);
5787       else
5788         assert (! divide);
5789     }
5790 #endif  /* HAHA */
5791
5792     expand_expr_stmt (ffecom_modify (void_type_node,
5793                                      rtmp,
5794                                      r));
5795     expand_expr_stmt (ffecom_modify (void_type_node,
5796                                      ltmp,
5797                                      l));
5798     expand_start_cond (ffecom_truth_value
5799                        (ffecom_2 (EQ_EXPR, integer_type_node,
5800                                   rtmp,
5801                                   convert (rtype, integer_zero_node))),
5802                        0);
5803     expand_expr_stmt (ffecom_modify (void_type_node,
5804                                      result,
5805                                      convert (ltype, integer_one_node)));
5806     expand_start_else ();
5807     if (! integer_zerop (basetypeof_l_is_int))
5808       {
5809         expand_start_cond (ffecom_2 (LT_EXPR, integer_type_node,
5810                                      rtmp,
5811                                      convert (rtype,
5812                                               integer_zero_node)),
5813                            0);
5814         expand_expr_stmt (ffecom_modify (void_type_node,
5815                                          result,
5816                                          ffecom_tree_divide_
5817                                          (ltype,
5818                                           convert (ltype, integer_one_node),
5819                                           ltmp,
5820                                           NULL_TREE, NULL, NULL,
5821                                           divide)));
5822         expand_start_cond (ffecom_truth_value
5823                            (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5824                                       ffecom_2 (LT_EXPR, integer_type_node,
5825                                                 ltmp,
5826                                                 convert (ltype,
5827                                                          integer_zero_node)),
5828                                       ffecom_2 (EQ_EXPR, integer_type_node,
5829                                                 ffecom_2 (BIT_AND_EXPR,
5830                                                           rtype,
5831                                                           ffecom_1 (NEGATE_EXPR,
5832                                                                     rtype,
5833                                                                     rtmp),
5834                                                           convert (rtype,
5835                                                                    integer_one_node)),
5836                                                 convert (rtype,
5837                                                          integer_zero_node)))),
5838                            0);
5839         expand_expr_stmt (ffecom_modify (void_type_node,
5840                                          result,
5841                                          ffecom_1 (NEGATE_EXPR,
5842                                                    ltype,
5843                                                    result)));
5844         expand_end_cond ();
5845         expand_start_else ();
5846       }
5847     expand_expr_stmt (ffecom_modify (void_type_node,
5848                                      result,
5849                                      convert (ltype, integer_one_node)));
5850     expand_start_cond (ffecom_truth_value
5851                        (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5852                                   ffecom_truth_value_invert
5853                                   (basetypeof_l_is_int),
5854                                   ffecom_2 (LT_EXPR, integer_type_node,
5855                                             rtmp,
5856                                             convert (rtype,
5857                                                      integer_zero_node)))),
5858                        0);
5859     expand_expr_stmt (ffecom_modify (void_type_node,
5860                                      ltmp,
5861                                      ffecom_tree_divide_
5862                                      (ltype,
5863                                       convert (ltype, integer_one_node),
5864                                       ltmp,
5865                                       NULL_TREE, NULL, NULL,
5866                                       divide)));
5867     expand_expr_stmt (ffecom_modify (void_type_node,
5868                                      rtmp,
5869                                      ffecom_1 (NEGATE_EXPR, rtype,
5870                                                rtmp)));
5871     expand_start_cond (ffecom_truth_value
5872                        (ffecom_2 (LT_EXPR, integer_type_node,
5873                                   rtmp,
5874                                   convert (rtype, integer_zero_node))),
5875                        0);
5876     expand_expr_stmt (ffecom_modify (void_type_node,
5877                                      rtmp,
5878                                      ffecom_1 (NEGATE_EXPR, rtype,
5879                                                ffecom_2 (RSHIFT_EXPR,
5880                                                          rtype,
5881                                                          rtmp,
5882                                                          integer_one_node))));
5883     expand_expr_stmt (ffecom_modify (void_type_node,
5884                                      ltmp,
5885                                      ffecom_2 (MULT_EXPR, ltype,
5886                                                ltmp,
5887                                                ltmp)));
5888     expand_end_cond ();
5889     expand_end_cond ();
5890     expand_start_loop (1);
5891     expand_start_cond (ffecom_truth_value
5892                        (ffecom_2 (BIT_AND_EXPR, rtype,
5893                                   rtmp,
5894                                   convert (rtype, integer_one_node))),
5895                        0);
5896     expand_expr_stmt (ffecom_modify (void_type_node,
5897                                      result,
5898                                      ffecom_2 (MULT_EXPR, ltype,
5899                                                result,
5900                                                ltmp)));
5901     expand_end_cond ();
5902     expand_exit_loop_if_false (NULL,
5903                                ffecom_truth_value
5904                                (ffecom_modify (rtype,
5905                                                rtmp,
5906                                                ffecom_2 (RSHIFT_EXPR,
5907                                                          rtype,
5908                                                          rtmp,
5909                                                          integer_one_node))));
5910     expand_expr_stmt (ffecom_modify (void_type_node,
5911                                      ltmp,
5912                                      ffecom_2 (MULT_EXPR, ltype,
5913                                                ltmp,
5914                                                ltmp)));
5915     expand_end_loop ();
5916     expand_end_cond ();
5917     if (!integer_zerop (basetypeof_l_is_int))
5918       expand_end_cond ();
5919     expand_expr_stmt (result);
5920
5921     t = ffecom_end_compstmt ();
5922
5923     result = expand_end_stmt_expr (se);
5924
5925     /* This code comes from c-parse.in, after its expand_end_stmt_expr.  */
5926
5927     if (TREE_CODE (t) == BLOCK)
5928       {
5929         /* Make a BIND_EXPR for the BLOCK already made.  */
5930         result = build (BIND_EXPR, TREE_TYPE (result),
5931                         NULL_TREE, result, t);
5932         /* Remove the block from the tree at this point.
5933            It gets put back at the proper place
5934            when the BIND_EXPR is expanded.  */
5935         delete_block (t);
5936       }
5937     else
5938       result = t;
5939   }
5940
5941   return result;
5942 }
5943
5944 #endif
5945 /* ffecom_expr_transform_ -- Transform symbols in expr
5946
5947    ffebld expr;  // FFE expression.
5948    ffecom_expr_transform_ (expr);
5949
5950    Recursive descent on expr while transforming any untransformed SYMTERs.  */
5951
5952 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5953 static void
5954 ffecom_expr_transform_ (ffebld expr)
5955 {
5956   tree t;
5957   ffesymbol s;
5958
5959 tail_recurse:                   /* :::::::::::::::::::: */
5960
5961   if (expr == NULL)
5962     return;
5963
5964   switch (ffebld_op (expr))
5965     {
5966     case FFEBLD_opSYMTER:
5967       s = ffebld_symter (expr);
5968       t = ffesymbol_hook (s).decl_tree;
5969       if ((t == NULL_TREE)
5970           && ((ffesymbol_kind (s) != FFEINFO_kindNONE)
5971               || ((ffesymbol_where (s) != FFEINFO_whereNONE)
5972                   && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC))))
5973         {
5974           s = ffecom_sym_transform_ (s);
5975           t = ffesymbol_hook (s).decl_tree;     /* Sfunc expr non-dummy,
5976                                                    DIMENSION expr? */
5977         }
5978       break;                    /* Ok if (t == NULL) here. */
5979
5980     case FFEBLD_opITEM:
5981       ffecom_expr_transform_ (ffebld_head (expr));
5982       expr = ffebld_trail (expr);
5983       goto tail_recurse;        /* :::::::::::::::::::: */
5984
5985     default:
5986       break;
5987     }
5988
5989   switch (ffebld_arity (expr))
5990     {
5991     case 2:
5992       ffecom_expr_transform_ (ffebld_left (expr));
5993       expr = ffebld_right (expr);
5994       goto tail_recurse;        /* :::::::::::::::::::: */
5995
5996     case 1:
5997       expr = ffebld_left (expr);
5998       goto tail_recurse;        /* :::::::::::::::::::: */
5999
6000     default:
6001       break;
6002     }
6003
6004   return;
6005 }
6006
6007 #endif
6008 /* Make a type based on info in live f2c.h file.  */
6009
6010 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6011 static void
6012 ffecom_f2c_make_type_ (tree *type, int tcode, const char *name)
6013 {
6014   switch (tcode)
6015     {
6016     case FFECOM_f2ccodeCHAR:
6017       *type = make_signed_type (CHAR_TYPE_SIZE);
6018       break;
6019
6020     case FFECOM_f2ccodeSHORT:
6021       *type = make_signed_type (SHORT_TYPE_SIZE);
6022       break;
6023
6024     case FFECOM_f2ccodeINT:
6025       *type = make_signed_type (INT_TYPE_SIZE);
6026       break;
6027
6028     case FFECOM_f2ccodeLONG:
6029       *type = make_signed_type (LONG_TYPE_SIZE);
6030       break;
6031
6032     case FFECOM_f2ccodeLONGLONG:
6033       *type = make_signed_type (LONG_LONG_TYPE_SIZE);
6034       break;
6035
6036     case FFECOM_f2ccodeCHARPTR:
6037       *type = build_pointer_type (DEFAULT_SIGNED_CHAR
6038                                   ? signed_char_type_node
6039                                   : unsigned_char_type_node);
6040       break;
6041
6042     case FFECOM_f2ccodeFLOAT:
6043       *type = make_node (REAL_TYPE);
6044       TYPE_PRECISION (*type) = FLOAT_TYPE_SIZE;
6045       layout_type (*type);
6046       break;
6047
6048     case FFECOM_f2ccodeDOUBLE:
6049       *type = make_node (REAL_TYPE);
6050       TYPE_PRECISION (*type) = DOUBLE_TYPE_SIZE;
6051       layout_type (*type);
6052       break;
6053
6054     case FFECOM_f2ccodeLONGDOUBLE:
6055       *type = make_node (REAL_TYPE);
6056       TYPE_PRECISION (*type) = LONG_DOUBLE_TYPE_SIZE;
6057       layout_type (*type);
6058       break;
6059
6060     case FFECOM_f2ccodeTWOREALS:
6061       *type = ffecom_make_complex_type_ (ffecom_f2c_real_type_node);
6062       break;
6063
6064     case FFECOM_f2ccodeTWODOUBLEREALS:
6065       *type = ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node);
6066       break;
6067
6068     default:
6069       assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL);
6070       *type = error_mark_node;
6071       return;
6072     }
6073
6074   pushdecl (build_decl (TYPE_DECL,
6075                         ffecom_get_invented_identifier ("__g77_f2c_%s",
6076                                                         name, -1),
6077                         *type));
6078 }
6079
6080 #endif
6081 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6082 /* Set the f2c list-directed-I/O code for whatever (integral) type has the
6083    given size.  */
6084
6085 static void
6086 ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
6087                           int code)
6088 {
6089   int j;
6090   tree t;
6091
6092   for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
6093     if (((t = ffecom_tree_type[bt][j]) != NULL_TREE)
6094         && (TREE_INT_CST_LOW (TYPE_SIZE (t)) == size))
6095       {
6096         assert (code != -1);
6097         ffecom_f2c_typecode_[bt][j] = code;
6098         code = -1;
6099       }
6100 }
6101
6102 #endif
6103 /* Finish up globals after doing all program units in file
6104
6105    Need to handle only uninitialized COMMON areas.  */
6106
6107 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6108 static ffeglobal
6109 ffecom_finish_global_ (ffeglobal global)
6110 {
6111   tree cbtype;
6112   tree cbt;
6113   tree size;
6114
6115   if (ffeglobal_type (global) != FFEGLOBAL_typeCOMMON)
6116       return global;
6117
6118   if (ffeglobal_common_init (global))
6119       return global;
6120
6121   cbt = ffeglobal_hook (global);
6122   if ((cbt == NULL_TREE)
6123       || !ffeglobal_common_have_size (global))
6124     return global;              /* No need to make common, never ref'd. */
6125
6126   suspend_momentary ();
6127
6128   DECL_EXTERNAL (cbt) = 0;
6129
6130   /* Give the array a size now.  */
6131
6132   size = build_int_2 ((ffeglobal_common_size (global)
6133                       + ffeglobal_common_pad (global)) - 1,
6134                       0);
6135
6136   cbtype = TREE_TYPE (cbt);
6137   TYPE_DOMAIN (cbtype) = build_range_type (integer_type_node,
6138                                            integer_zero_node,
6139                                            size);
6140   if (!TREE_TYPE (size))
6141     TREE_TYPE (size) = TYPE_DOMAIN (cbtype);
6142   layout_type (cbtype);
6143
6144   cbt = start_decl (cbt, FALSE);
6145   assert (cbt == ffeglobal_hook (global));
6146
6147   finish_decl (cbt, NULL_TREE, FALSE);
6148
6149   return global;
6150 }
6151
6152 #endif
6153 /* Finish up any untransformed symbols.  */
6154
6155 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6156 static ffesymbol
6157 ffecom_finish_symbol_transform_ (ffesymbol s)
6158 {
6159   if ((s == NULL) || (TREE_CODE (current_function_decl) == ERROR_MARK))
6160     return s;
6161
6162   /* It's easy to know to transform an untransformed symbol, to make sure
6163      we put out debugging info for it.  But COMMON variables, unlike
6164      EQUIVALENCE ones, aren't given declarations in addition to the
6165      tree expressions that specify offsets, because COMMON variables
6166      can be referenced in the outer scope where only dummy arguments
6167      (PARM_DECLs) should really be seen.  To be safe, just don't do any
6168      VAR_DECLs for COMMON variables when we transform them for real
6169      use, and therefore we do all the VAR_DECL creating here.  */
6170
6171   if (ffesymbol_hook (s).decl_tree == NULL_TREE)
6172     {
6173       if (ffesymbol_kind (s) != FFEINFO_kindNONE
6174           || (ffesymbol_where (s) != FFEINFO_whereNONE
6175               && ffesymbol_where (s) != FFEINFO_whereINTRINSIC
6176               && ffesymbol_where (s) != FFEINFO_whereDUMMY))
6177         /* Not transformed, and not CHARACTER*(*), and not a dummy
6178            argument, which can happen only if the entry point names
6179            it "rides in on" are all invalidated for other reasons.  */
6180         s = ffecom_sym_transform_ (s);
6181     }
6182
6183   if ((ffesymbol_where (s) == FFEINFO_whereCOMMON)
6184       && (ffesymbol_hook (s).decl_tree != error_mark_node))
6185     {
6186 #ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
6187       int yes = suspend_momentary ();
6188
6189       /* This isn't working, at least for dbxout.  The .s file looks
6190          okay to me (burley), but in gdb 4.9 at least, the variables
6191          appear to reside somewhere outside of the common area, so
6192          it doesn't make sense to mislead anyone by generating the info
6193          on those variables until this is fixed.  NOTE: Same problem
6194          with EQUIVALENCE, sadly...see similar #if later.  */
6195       ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s)),
6196                              ffesymbol_storage (s));
6197
6198       resume_momentary (yes);
6199 #endif
6200     }
6201
6202   return s;
6203 }
6204
6205 #endif
6206 /* Append underscore(s) to name before calling get_identifier.  "us"
6207    is nonzero if the name already contains an underscore and thus
6208    needs two underscores appended.  */
6209
6210 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6211 static tree
6212 ffecom_get_appended_identifier_ (char us, const char *name)
6213 {
6214   int i;
6215   char *newname;
6216   tree id;
6217
6218   newname = xmalloc ((i = strlen (name)) + 1
6219                      + ffe_is_underscoring ()
6220                      + us);
6221   memcpy (newname, name, i);
6222   newname[i] = '_';
6223   newname[i + us] = '_';
6224   newname[i + 1 + us] = '\0';
6225   id = get_identifier (newname);
6226
6227   free (newname);
6228
6229   return id;
6230 }
6231
6232 #endif
6233 /* Decide whether to append underscore to name before calling
6234    get_identifier.  */
6235
6236 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6237 static tree
6238 ffecom_get_external_identifier_ (ffesymbol s)
6239 {
6240   char us;
6241   const char *name = ffesymbol_text (s);
6242
6243   /* If name is a built-in name, just return it as is.  */
6244
6245   if (!ffe_is_underscoring ()
6246       || (strcmp (name, FFETARGET_nameBLANK_COMMON) == 0)
6247 #if FFETARGET_isENFORCED_MAIN_NAME
6248       || (strcmp (name, FFETARGET_nameENFORCED_NAME) == 0)
6249 #else
6250       || (strcmp (name, FFETARGET_nameUNNAMED_MAIN) == 0)
6251 #endif
6252       || (strcmp (name, FFETARGET_nameUNNAMED_BLOCK_DATA) == 0))
6253     return get_identifier (name);
6254
6255   us = ffe_is_second_underscore ()
6256     ? (strchr (name, '_') != NULL)
6257       : 0;
6258
6259   return ffecom_get_appended_identifier_ (us, name);
6260 }
6261
6262 #endif
6263 /* Decide whether to append underscore to internal name before calling
6264    get_identifier.
6265
6266    This is for non-external, top-function-context names only.  Transform
6267    identifier so it doesn't conflict with the transformed result
6268    of using a _different_ external name.  E.g. if "CALL FOO" is
6269    transformed into "FOO_();", then the variable in "FOO_ = 3"
6270    must be transformed into something that does not conflict, since
6271    these two things should be independent.
6272
6273    The transformation is as follows.  If the name does not contain
6274    an underscore, there is no possible conflict, so just return.
6275    If the name does contain an underscore, then transform it just
6276    like we transform an external identifier.  */
6277
6278 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6279 static tree
6280 ffecom_get_identifier_ (const char *name)
6281 {
6282   /* If name does not contain an underscore, just return it as is.  */
6283
6284   if (!ffe_is_underscoring ()
6285       || (strchr (name, '_') == NULL))
6286     return get_identifier (name);
6287
6288   return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
6289                                           name);
6290 }
6291
6292 #endif
6293 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
6294
6295    tree t;
6296    ffesymbol s;  // kindFUNCTION, whereIMMEDIATE.
6297    t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
6298          ffesymbol_kindtype(s));
6299
6300    Call after setting up containing function and getting trees for all
6301    other symbols.  */
6302
6303 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6304 static tree
6305 ffecom_gen_sfuncdef_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt)
6306 {
6307   ffebld expr = ffesymbol_sfexpr (s);
6308   tree type;
6309   tree func;
6310   tree result;
6311   bool charfunc = (bt == FFEINFO_basictypeCHARACTER);
6312   static bool recurse = FALSE;
6313   int yes;
6314   int old_lineno = lineno;
6315   char *old_input_filename = input_filename;
6316
6317   ffecom_nested_entry_ = s;
6318
6319   /* For now, we don't have a handy pointer to where the sfunc is actually
6320      defined, though that should be easy to add to an ffesymbol. (The
6321      token/where info available might well point to the place where the type
6322      of the sfunc is declared, especially if that precedes the place where
6323      the sfunc itself is defined, which is typically the case.)  We should
6324      put out a null pointer rather than point somewhere wrong, but I want to
6325      see how it works at this point.  */
6326
6327   input_filename = ffesymbol_where_filename (s);
6328   lineno = ffesymbol_where_filelinenum (s);
6329
6330   /* Pretransform the expression so any newly discovered things belong to the
6331      outer program unit, not to the statement function. */
6332
6333   ffecom_expr_transform_ (expr);
6334
6335   /* Make sure no recursive invocation of this fn (a specific case of failing
6336      to pretransform an sfunc's expression, i.e. where its expression
6337      references another untransformed sfunc) happens. */
6338
6339   assert (!recurse);
6340   recurse = TRUE;
6341
6342   yes = suspend_momentary ();
6343
6344   push_f_function_context ();
6345
6346   if (charfunc)
6347     type = void_type_node;
6348   else
6349     {
6350       type = ffecom_tree_type[bt][kt];
6351       if (type == NULL_TREE)
6352         type = integer_type_node;       /* _sym_exec_transition reports
6353                                            error. */
6354     }
6355
6356   start_function (ffecom_get_identifier_ (ffesymbol_text (s)),
6357                   build_function_type (type, NULL_TREE),
6358                   1,            /* nested/inline */
6359                   0);           /* TREE_PUBLIC */
6360
6361   /* We don't worry about COMPLEX return values here, because this is
6362      entirely internal to our code, and gcc has the ability to return COMPLEX
6363      directly as a value.  */
6364
6365   yes = suspend_momentary ();
6366
6367   if (charfunc)
6368     {                           /* Prepend arg for where result goes. */
6369       tree type;
6370
6371       type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
6372
6373       result = ffecom_get_invented_identifier ("__g77_%s",
6374                                                "result", -1);
6375
6376       ffecom_char_enhance_arg_ (&type, s);      /* Ignore returned length. */
6377
6378       type = build_pointer_type (type);
6379       result = build_decl (PARM_DECL, result, type);
6380
6381       push_parm_decl (result);
6382     }
6383   else
6384     result = NULL_TREE;         /* Not ref'd if !charfunc. */
6385
6386   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s), TRUE);
6387
6388   resume_momentary (yes);
6389
6390   store_parm_decls (0);
6391
6392   ffecom_start_compstmt ();
6393
6394   if (expr != NULL)
6395     {
6396       if (charfunc)
6397         {
6398           ffetargetCharacterSize sz = ffesymbol_size (s);
6399           tree result_length;
6400
6401           result_length = build_int_2 (sz, 0);
6402           TREE_TYPE (result_length) = ffecom_f2c_ftnlen_type_node;
6403
6404           ffecom_prepare_let_char_ (sz, expr);
6405
6406           ffecom_prepare_end ();
6407
6408           ffecom_let_char_ (result, result_length, sz, expr);
6409           expand_null_return ();
6410         }
6411       else
6412         {
6413           ffecom_prepare_expr (expr);
6414
6415           ffecom_prepare_end ();
6416
6417           expand_return (ffecom_modify (NULL_TREE,
6418                                         DECL_RESULT (current_function_decl),
6419                                         ffecom_expr (expr)));
6420         }
6421
6422       clear_momentary ();
6423     }
6424
6425   ffecom_end_compstmt ();
6426
6427   func = current_function_decl;
6428   finish_function (1);
6429
6430   pop_f_function_context ();
6431
6432   resume_momentary (yes);
6433
6434   recurse = FALSE;
6435
6436   lineno = old_lineno;
6437   input_filename = old_input_filename;
6438
6439   ffecom_nested_entry_ = NULL;
6440
6441   return func;
6442 }
6443
6444 #endif
6445
6446 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6447 static const char *
6448 ffecom_gfrt_args_ (ffecomGfrt ix)
6449 {
6450   return ffecom_gfrt_argstring_[ix];
6451 }
6452
6453 #endif
6454 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6455 static tree
6456 ffecom_gfrt_tree_ (ffecomGfrt ix)
6457 {
6458   if (ffecom_gfrt_[ix] == NULL_TREE)
6459     ffecom_make_gfrt_ (ix);
6460
6461   return ffecom_1 (ADDR_EXPR,
6462                    build_pointer_type (TREE_TYPE (ffecom_gfrt_[ix])),
6463                    ffecom_gfrt_[ix]);
6464 }
6465
6466 #endif
6467 /* Return initialize-to-zero expression for this VAR_DECL.  */
6468
6469 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6470 static tree
6471 ffecom_init_zero_ (tree decl)
6472 {
6473   tree init;
6474   int incremental = TREE_STATIC (decl);
6475   tree type = TREE_TYPE (decl);
6476
6477   if (incremental)
6478     {
6479       int momentary = suspend_momentary ();
6480       push_obstacks_nochange ();
6481       if (TREE_PERMANENT (decl))
6482         end_temporary_allocation ();
6483       make_decl_rtl (decl, NULL, TREE_PUBLIC (decl) ? 1 : 0);
6484       assemble_variable (decl, TREE_PUBLIC (decl) ? 1 : 0, 0, 1);
6485       pop_obstacks ();
6486       resume_momentary (momentary);
6487     }
6488
6489   push_momentary ();
6490
6491   if ((TREE_CODE (type) != ARRAY_TYPE)
6492       && (TREE_CODE (type) != RECORD_TYPE)
6493       && (TREE_CODE (type) != UNION_TYPE)
6494       && !incremental)
6495     init = convert (type, integer_zero_node);
6496   else if (!incremental)
6497     {
6498       int momentary = suspend_momentary ();
6499
6500       init = build (CONSTRUCTOR, type, NULL_TREE, NULL_TREE);
6501       TREE_CONSTANT (init) = 1;
6502       TREE_STATIC (init) = 1;
6503
6504       resume_momentary (momentary);
6505     }
6506   else
6507     {
6508       int momentary = suspend_momentary ();
6509
6510       assemble_zeros (int_size_in_bytes (type));
6511       init = error_mark_node;
6512
6513       resume_momentary (momentary);
6514     }
6515
6516   pop_momentary_nofree ();
6517
6518   return init;
6519 }
6520
6521 #endif
6522 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6523 static tree
6524 ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
6525                          tree *maybe_tree)
6526 {
6527   tree expr_tree;
6528   tree length_tree;
6529
6530   switch (ffebld_op (arg))
6531     {
6532     case FFEBLD_opCONTER:       /* For F90, check 0-length. */
6533       if (ffetarget_length_character1
6534           (ffebld_constant_character1
6535            (ffebld_conter (arg))) == 0)
6536         {
6537           *maybe_tree = integer_zero_node;
6538           return convert (tree_type, integer_zero_node);
6539         }
6540
6541       *maybe_tree = integer_one_node;
6542       expr_tree = build_int_2 (*ffetarget_text_character1
6543                                (ffebld_constant_character1
6544                                 (ffebld_conter (arg))),
6545                                0);
6546       TREE_TYPE (expr_tree) = tree_type;
6547       return expr_tree;
6548
6549     case FFEBLD_opSYMTER:
6550     case FFEBLD_opARRAYREF:
6551     case FFEBLD_opFUNCREF:
6552     case FFEBLD_opSUBSTR:
6553       ffecom_char_args_ (&expr_tree, &length_tree, arg);
6554
6555       if ((expr_tree == error_mark_node)
6556           || (length_tree == error_mark_node))
6557         {
6558           *maybe_tree = error_mark_node;
6559           return error_mark_node;
6560         }
6561
6562       if (integer_zerop (length_tree))
6563         {
6564           *maybe_tree = integer_zero_node;
6565           return convert (tree_type, integer_zero_node);
6566         }
6567
6568       expr_tree
6569         = ffecom_1 (INDIRECT_REF,
6570                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6571                     expr_tree);
6572       expr_tree
6573         = ffecom_2 (ARRAY_REF,
6574                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6575                     expr_tree,
6576                     integer_one_node);
6577       expr_tree = convert (tree_type, expr_tree);
6578
6579       if (TREE_CODE (length_tree) == INTEGER_CST)
6580         *maybe_tree = integer_one_node;
6581       else                      /* Must check length at run time.  */
6582         *maybe_tree
6583           = ffecom_truth_value
6584             (ffecom_2 (GT_EXPR, integer_type_node,
6585                        length_tree,
6586                        ffecom_f2c_ftnlen_zero_node));
6587       return expr_tree;
6588
6589     case FFEBLD_opPAREN:
6590     case FFEBLD_opCONVERT:
6591       if (ffeinfo_size (ffebld_info (arg)) == 0)
6592         {
6593           *maybe_tree = integer_zero_node;
6594           return convert (tree_type, integer_zero_node);
6595         }
6596       return ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6597                                       maybe_tree);
6598
6599     case FFEBLD_opCONCATENATE:
6600       {
6601         tree maybe_left;
6602         tree maybe_right;
6603         tree expr_left;
6604         tree expr_right;
6605
6606         expr_left = ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6607                                              &maybe_left);
6608         expr_right = ffecom_intrinsic_ichar_ (tree_type, ffebld_right (arg),
6609                                               &maybe_right);
6610         *maybe_tree = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
6611                                 maybe_left,
6612                                 maybe_right);
6613         expr_tree = ffecom_3 (COND_EXPR, tree_type,
6614                               maybe_left,
6615                               expr_left,
6616                               expr_right);
6617         return expr_tree;
6618       }
6619
6620     default:
6621       assert ("bad op in ICHAR" == NULL);
6622       return error_mark_node;
6623     }
6624 }
6625
6626 #endif
6627 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
6628
6629    tree length_arg;
6630    ffebld expr;
6631    length_arg = ffecom_intrinsic_len_ (expr);
6632
6633    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
6634    subexpressions by constructing the appropriate tree for the
6635    length-of-character-text argument in a calling sequence.  */
6636
6637 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6638 static tree
6639 ffecom_intrinsic_len_ (ffebld expr)
6640 {
6641   ffetargetCharacter1 val;
6642   tree length;
6643
6644   switch (ffebld_op (expr))
6645     {
6646     case FFEBLD_opCONTER:
6647       val = ffebld_constant_character1 (ffebld_conter (expr));
6648       length = build_int_2 (ffetarget_length_character1 (val), 0);
6649       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6650       break;
6651
6652     case FFEBLD_opSYMTER:
6653       {
6654         ffesymbol s = ffebld_symter (expr);
6655         tree item;
6656
6657         item = ffesymbol_hook (s).decl_tree;
6658         if (item == NULL_TREE)
6659           {
6660             s = ffecom_sym_transform_ (s);
6661             item = ffesymbol_hook (s).decl_tree;
6662           }
6663         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
6664           {
6665             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
6666               length = ffesymbol_hook (s).length_tree;
6667             else
6668               {
6669                 length = build_int_2 (ffesymbol_size (s), 0);
6670                 TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6671               }
6672           }
6673         else if (item == error_mark_node)
6674           length = error_mark_node;
6675         else                    /* FFEINFO_kindFUNCTION: */
6676           length = NULL_TREE;
6677       }
6678       break;
6679
6680     case FFEBLD_opARRAYREF:
6681       length = ffecom_intrinsic_len_ (ffebld_left (expr));
6682       break;
6683
6684     case FFEBLD_opSUBSTR:
6685       {
6686         ffebld start;
6687         ffebld end;
6688         ffebld thing = ffebld_right (expr);
6689         tree start_tree;
6690         tree end_tree;
6691
6692         assert (ffebld_op (thing) == FFEBLD_opITEM);
6693         start = ffebld_head (thing);
6694         thing = ffebld_trail (thing);
6695         assert (ffebld_trail (thing) == NULL);
6696         end = ffebld_head (thing);
6697
6698         length = ffecom_intrinsic_len_ (ffebld_left (expr));
6699
6700         if (length == error_mark_node)
6701           break;
6702
6703         if (start == NULL)
6704           {
6705             if (end == NULL)
6706               ;
6707             else
6708               {
6709                 length = convert (ffecom_f2c_ftnlen_type_node,
6710                                   ffecom_expr (end));
6711               }
6712           }
6713         else
6714           {
6715             start_tree = convert (ffecom_f2c_ftnlen_type_node,
6716                                   ffecom_expr (start));
6717
6718             if (start_tree == error_mark_node)
6719               {
6720                 length = error_mark_node;
6721                 break;
6722               }
6723
6724             if (end == NULL)
6725               {
6726                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6727                                    ffecom_f2c_ftnlen_one_node,
6728                                    ffecom_2 (MINUS_EXPR,
6729                                              ffecom_f2c_ftnlen_type_node,
6730                                              length,
6731                                              start_tree));
6732               }
6733             else
6734               {
6735                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
6736                                     ffecom_expr (end));
6737
6738                 if (end_tree == error_mark_node)
6739                   {
6740                     length = error_mark_node;
6741                     break;
6742                   }
6743
6744                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6745                                    ffecom_f2c_ftnlen_one_node,
6746                                    ffecom_2 (MINUS_EXPR,
6747                                              ffecom_f2c_ftnlen_type_node,
6748                                              end_tree, start_tree));
6749               }
6750           }
6751       }
6752       break;
6753
6754     case FFEBLD_opCONCATENATE:
6755       length
6756         = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6757                     ffecom_intrinsic_len_ (ffebld_left (expr)),
6758                     ffecom_intrinsic_len_ (ffebld_right (expr)));
6759       break;
6760
6761     case FFEBLD_opFUNCREF:
6762     case FFEBLD_opCONVERT:
6763       length = build_int_2 (ffebld_size (expr), 0);
6764       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6765       break;
6766
6767     default:
6768       assert ("bad op for single char arg expr" == NULL);
6769       length = ffecom_f2c_ftnlen_zero_node;
6770       break;
6771     }
6772
6773   assert (length != NULL_TREE);
6774
6775   return length;
6776 }
6777
6778 #endif
6779 /* Handle CHARACTER assignments.
6780
6781    Generates code to do the assignment.  Used by ordinary assignment
6782    statement handler ffecom_let_stmt and by statement-function
6783    handler to generate code for a statement function.  */
6784
6785 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6786 static void
6787 ffecom_let_char_ (tree dest_tree, tree dest_length,
6788                   ffetargetCharacterSize dest_size, ffebld source)
6789 {
6790   ffecomConcatList_ catlist;
6791   tree source_length;
6792   tree source_tree;
6793   tree expr_tree;
6794
6795   if ((dest_tree == error_mark_node)
6796       || (dest_length == error_mark_node))
6797     return;
6798
6799   assert (dest_tree != NULL_TREE);
6800   assert (dest_length != NULL_TREE);
6801
6802   /* Source might be an opCONVERT, which just means it is a different size
6803      than the destination.  Since the underlying implementation here handles
6804      that (directly or via the s_copy or s_cat run-time-library functions),
6805      we don't need the "convenience" of an opCONVERT that tells us to
6806      truncate or blank-pad, particularly since the resulting implementation
6807      would probably be slower than otherwise. */
6808
6809   while (ffebld_op (source) == FFEBLD_opCONVERT)
6810     source = ffebld_left (source);
6811
6812   catlist = ffecom_concat_list_new_ (source, dest_size);
6813   switch (ffecom_concat_list_count_ (catlist))
6814     {
6815     case 0:                     /* Shouldn't happen, but in case it does... */
6816       ffecom_concat_list_kill_ (catlist);
6817       source_tree = null_pointer_node;
6818       source_length = ffecom_f2c_ftnlen_zero_node;
6819       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6820       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6821       TREE_CHAIN (TREE_CHAIN (expr_tree))
6822         = build_tree_list (NULL_TREE, dest_length);
6823       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6824         = build_tree_list (NULL_TREE, source_length);
6825
6826       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6827       TREE_SIDE_EFFECTS (expr_tree) = 1;
6828
6829       expand_expr_stmt (expr_tree);
6830
6831       return;
6832
6833     case 1:                     /* The (fairly) easy case. */
6834       ffecom_char_args_ (&source_tree, &source_length,
6835                          ffecom_concat_list_expr_ (catlist, 0));
6836       ffecom_concat_list_kill_ (catlist);
6837       assert (source_tree != NULL_TREE);
6838       assert (source_length != NULL_TREE);
6839
6840       if ((source_tree == error_mark_node)
6841           || (source_length == error_mark_node))
6842         return;
6843
6844       if (dest_size == 1)
6845         {
6846           dest_tree
6847             = ffecom_1 (INDIRECT_REF,
6848                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6849                                                       (dest_tree))),
6850                         dest_tree);
6851           dest_tree
6852             = ffecom_2 (ARRAY_REF,
6853                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6854                                                       (dest_tree))),
6855                         dest_tree,
6856                         integer_one_node);
6857           source_tree
6858             = ffecom_1 (INDIRECT_REF,
6859                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6860                                                       (source_tree))),
6861                         source_tree);
6862           source_tree
6863             = ffecom_2 (ARRAY_REF,
6864                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6865                                                       (source_tree))),
6866                         source_tree,
6867                         integer_one_node);
6868
6869           expr_tree = ffecom_modify (void_type_node, dest_tree, source_tree);
6870
6871           expand_expr_stmt (expr_tree);
6872
6873           return;
6874         }
6875
6876       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6877       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6878       TREE_CHAIN (TREE_CHAIN (expr_tree))
6879         = build_tree_list (NULL_TREE, dest_length);
6880       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6881         = build_tree_list (NULL_TREE, source_length);
6882
6883       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6884       TREE_SIDE_EFFECTS (expr_tree) = 1;
6885
6886       expand_expr_stmt (expr_tree);
6887
6888       return;
6889
6890     default:                    /* Must actually concatenate things. */
6891       break;
6892     }
6893
6894   /* Heavy-duty concatenation. */
6895
6896   {
6897     int count = ffecom_concat_list_count_ (catlist);
6898     int i;
6899     tree lengths;
6900     tree items;
6901     tree length_array;
6902     tree item_array;
6903     tree citem;
6904     tree clength;
6905
6906 #ifdef HOHO
6907     length_array
6908       = lengths
6909       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
6910                              FFETARGET_charactersizeNONE, count, TRUE);
6911     item_array = items = ffecom_push_tempvar (ffecom_f2c_address_type_node,
6912                                               FFETARGET_charactersizeNONE,
6913                                               count, TRUE);
6914 #else
6915     {
6916       tree hook;
6917
6918       hook = ffebld_nonter_hook (source);
6919       assert (hook);
6920       assert (TREE_CODE (hook) == TREE_VEC);
6921       assert (TREE_VEC_LENGTH (hook) == 2);
6922       length_array = lengths = TREE_VEC_ELT (hook, 0);
6923       item_array = items = TREE_VEC_ELT (hook, 1);
6924     }
6925 #endif
6926
6927     for (i = 0; i < count; ++i)
6928       {
6929         ffecom_char_args_ (&citem, &clength,
6930                            ffecom_concat_list_expr_ (catlist, i));
6931         if ((citem == error_mark_node)
6932             || (clength == error_mark_node))
6933           {
6934             ffecom_concat_list_kill_ (catlist);
6935             return;
6936           }
6937
6938         items
6939           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
6940                       ffecom_modify (void_type_node,
6941                                      ffecom_2 (ARRAY_REF,
6942                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
6943                                                item_array,
6944                                                build_int_2 (i, 0)),
6945                                      citem),
6946                       items);
6947         lengths
6948           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
6949                       ffecom_modify (void_type_node,
6950                                      ffecom_2 (ARRAY_REF,
6951                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
6952                                                length_array,
6953                                                build_int_2 (i, 0)),
6954                                      clength),
6955                       lengths);
6956       }
6957
6958     expr_tree = build_tree_list (NULL_TREE, dest_tree);
6959     TREE_CHAIN (expr_tree)
6960       = build_tree_list (NULL_TREE,
6961                          ffecom_1 (ADDR_EXPR,
6962                                    build_pointer_type (TREE_TYPE (items)),
6963                                    items));
6964     TREE_CHAIN (TREE_CHAIN (expr_tree))
6965       = build_tree_list (NULL_TREE,
6966                          ffecom_1 (ADDR_EXPR,
6967                                    build_pointer_type (TREE_TYPE (lengths)),
6968                                    lengths));
6969     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6970       = build_tree_list
6971         (NULL_TREE,
6972          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
6973                    convert (ffecom_f2c_ftnlen_type_node,
6974                             build_int_2 (count, 0))));
6975     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))))
6976       = build_tree_list (NULL_TREE, dest_length);
6977
6978     expr_tree = ffecom_call_gfrt (FFECOM_gfrtCAT, expr_tree, NULL_TREE);
6979     TREE_SIDE_EFFECTS (expr_tree) = 1;
6980
6981     expand_expr_stmt (expr_tree);
6982   }
6983
6984   ffecom_concat_list_kill_ (catlist);
6985 }
6986
6987 #endif
6988 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
6989
6990    ffecomGfrt ix;
6991    ffecom_make_gfrt_(ix);
6992
6993    Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
6994    for the indicated run-time routine (ix).  */
6995
6996 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6997 static void
6998 ffecom_make_gfrt_ (ffecomGfrt ix)
6999 {
7000   tree t;
7001   tree ttype;
7002
7003   push_obstacks_nochange ();
7004   end_temporary_allocation ();
7005
7006   switch (ffecom_gfrt_type_[ix])
7007     {
7008     case FFECOM_rttypeVOID_:
7009       ttype = void_type_node;
7010       break;
7011
7012     case FFECOM_rttypeVOIDSTAR_:
7013       ttype = TREE_TYPE (null_pointer_node);    /* `void *'. */
7014       break;
7015
7016     case FFECOM_rttypeFTNINT_:
7017       ttype = ffecom_f2c_ftnint_type_node;
7018       break;
7019
7020     case FFECOM_rttypeINTEGER_:
7021       ttype = ffecom_f2c_integer_type_node;
7022       break;
7023
7024     case FFECOM_rttypeLONGINT_:
7025       ttype = ffecom_f2c_longint_type_node;
7026       break;
7027
7028     case FFECOM_rttypeLOGICAL_:
7029       ttype = ffecom_f2c_logical_type_node;
7030       break;
7031
7032     case FFECOM_rttypeREAL_F2C_:
7033       ttype = double_type_node;
7034       break;
7035
7036     case FFECOM_rttypeREAL_GNU_:
7037       ttype = float_type_node;
7038       break;
7039
7040     case FFECOM_rttypeCOMPLEX_F2C_:
7041       ttype = void_type_node;
7042       break;
7043
7044     case FFECOM_rttypeCOMPLEX_GNU_:
7045       ttype = ffecom_f2c_complex_type_node;
7046       break;
7047
7048     case FFECOM_rttypeDOUBLE_:
7049       ttype = double_type_node;
7050       break;
7051
7052     case FFECOM_rttypeDOUBLEREAL_:
7053       ttype = ffecom_f2c_doublereal_type_node;
7054       break;
7055
7056     case FFECOM_rttypeDBLCMPLX_F2C_:
7057       ttype = void_type_node;
7058       break;
7059
7060     case FFECOM_rttypeDBLCMPLX_GNU_:
7061       ttype = ffecom_f2c_doublecomplex_type_node;
7062       break;
7063
7064     case FFECOM_rttypeCHARACTER_:
7065       ttype = void_type_node;
7066       break;
7067
7068     default:
7069       ttype = NULL;
7070       assert ("bad rttype" == NULL);
7071       break;
7072     }
7073
7074   ttype = build_function_type (ttype, NULL_TREE);
7075   t = build_decl (FUNCTION_DECL,
7076                   get_identifier (ffecom_gfrt_name_[ix]),
7077                   ttype);
7078   DECL_EXTERNAL (t) = 1;
7079   TREE_PUBLIC (t) = 1;
7080   TREE_THIS_VOLATILE (t) = ffecom_gfrt_volatile_[ix] ? 1 : 0;
7081
7082   t = start_decl (t, TRUE);
7083
7084   finish_decl (t, NULL_TREE, TRUE);
7085
7086   resume_temporary_allocation ();
7087   pop_obstacks ();
7088
7089   ffecom_gfrt_[ix] = t;
7090 }
7091
7092 #endif
7093 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group.  */
7094
7095 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7096 static void
7097 ffecom_member_phase1_ (ffestorag mst UNUSED, ffestorag st)
7098 {
7099   ffesymbol s = ffestorag_symbol (st);
7100
7101   if (ffesymbol_namelisted (s))
7102     ffecom_member_namelisted_ = TRUE;
7103 }
7104
7105 #endif
7106 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group.  Declare
7107    the member so debugger will see it.  Otherwise nobody should be
7108    referencing the member.  */
7109
7110 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7111 #ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
7112 static void
7113 ffecom_member_phase2_ (ffestorag mst, ffestorag st)
7114 {
7115   ffesymbol s;
7116   tree t;
7117   tree mt;
7118   tree type;
7119
7120   if ((mst == NULL)
7121       || ((mt = ffestorag_hook (mst)) == NULL)
7122       || (mt == error_mark_node))
7123     return;
7124
7125   if ((st == NULL)
7126       || ((s = ffestorag_symbol (st)) == NULL))
7127     return;
7128
7129   type = ffecom_type_localvar_ (s,
7130                                 ffesymbol_basictype (s),
7131                                 ffesymbol_kindtype (s));
7132   if (type == error_mark_node)
7133     return;
7134
7135   t = build_decl (VAR_DECL,
7136                   ffecom_get_identifier_ (ffesymbol_text (s)),
7137                   type);
7138
7139   TREE_STATIC (t) = TREE_STATIC (mt);
7140   DECL_INITIAL (t) = NULL_TREE;
7141   TREE_ASM_WRITTEN (t) = 1;
7142
7143   DECL_RTL (t)
7144     = gen_rtx (MEM, TYPE_MODE (type),
7145                plus_constant (XEXP (DECL_RTL (mt), 0),
7146                               ffestorag_modulo (mst)
7147                               + ffestorag_offset (st)
7148                               - ffestorag_offset (mst)));
7149
7150   t = start_decl (t, FALSE);
7151
7152   finish_decl (t, NULL_TREE, FALSE);
7153 }
7154
7155 #endif
7156 #endif
7157 /* Prepare source expression for assignment into a destination perhaps known
7158    to be of a specific size.  */
7159
7160 static void
7161 ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size, ffebld source)
7162 {
7163   ffecomConcatList_ catlist;
7164   int count;
7165   int i;
7166   tree ltmp;
7167   tree itmp;
7168   tree tempvar = NULL_TREE;
7169
7170   while (ffebld_op (source) == FFEBLD_opCONVERT)
7171     source = ffebld_left (source);
7172
7173   catlist = ffecom_concat_list_new_ (source, dest_size);
7174   count = ffecom_concat_list_count_ (catlist);
7175
7176   if (count >= 2)
7177     {
7178       ltmp
7179         = ffecom_make_tempvar ("let_char_len", ffecom_f2c_ftnlen_type_node,
7180                                FFETARGET_charactersizeNONE, count);
7181       itmp
7182         = ffecom_make_tempvar ("let_char_item", ffecom_f2c_address_type_node,
7183                                FFETARGET_charactersizeNONE, count);
7184
7185       tempvar = make_tree_vec (2);
7186       TREE_VEC_ELT (tempvar, 0) = ltmp;
7187       TREE_VEC_ELT (tempvar, 1) = itmp;
7188     }
7189
7190   for (i = 0; i < count; ++i)
7191     ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist, i));
7192
7193   ffecom_concat_list_kill_ (catlist);
7194
7195   if (tempvar)
7196     {
7197       ffebld_nonter_set_hook (source, tempvar);
7198       current_binding_level->prep_state = 1;
7199     }
7200 }
7201
7202 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
7203
7204    Ignores STAR (alternate-return) dummies.  All other get exec-transitioned
7205    (which generates their trees) and then their trees get push_parm_decl'd.
7206
7207    The second arg is TRUE if the dummies are for a statement function, in
7208    which case lengths are not pushed for character arguments (since they are
7209    always known by both the caller and the callee, though the code allows
7210    for someday permitting CHAR*(*) stmtfunc dummies).  */
7211
7212 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7213 static void
7214 ffecom_push_dummy_decls_ (ffebld dummy_list, bool stmtfunc)
7215 {
7216   ffebld dummy;
7217   ffebld dumlist;
7218   ffesymbol s;
7219   tree parm;
7220
7221   ffecom_transform_only_dummies_ = TRUE;
7222
7223   /* First push the parms corresponding to actual dummy "contents".  */
7224
7225   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7226     {
7227       dummy = ffebld_head (dumlist);
7228       switch (ffebld_op (dummy))
7229         {
7230         case FFEBLD_opSTAR:
7231         case FFEBLD_opANY:
7232           continue;             /* Forget alternate returns. */
7233
7234         default:
7235           break;
7236         }
7237       assert (ffebld_op (dummy) == FFEBLD_opSYMTER);
7238       s = ffebld_symter (dummy);
7239       parm = ffesymbol_hook (s).decl_tree;
7240       if (parm == NULL_TREE)
7241         {
7242           s = ffecom_sym_transform_ (s);
7243           parm = ffesymbol_hook (s).decl_tree;
7244           assert (parm != NULL_TREE);
7245         }
7246       if (parm != error_mark_node)
7247         push_parm_decl (parm);
7248     }
7249
7250   /* Then, for CHARACTER dummies, push the parms giving their lengths.  */
7251
7252   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7253     {
7254       dummy = ffebld_head (dumlist);
7255       switch (ffebld_op (dummy))
7256         {
7257         case FFEBLD_opSTAR:
7258         case FFEBLD_opANY:
7259           continue;             /* Forget alternate returns, they mean
7260                                    NOTHING! */
7261
7262         default:
7263           break;
7264         }
7265       s = ffebld_symter (dummy);
7266       if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
7267         continue;               /* Only looking for CHARACTER arguments. */
7268       if (stmtfunc && (ffesymbol_size (s) != FFETARGET_charactersizeNONE))
7269         continue;               /* Stmtfunc arg with known size needs no
7270                                    length param. */
7271       if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
7272         continue;               /* Only looking for variables and arrays. */
7273       parm = ffesymbol_hook (s).length_tree;
7274       assert (parm != NULL_TREE);
7275       if (parm != error_mark_node)
7276         push_parm_decl (parm);
7277     }
7278
7279   ffecom_transform_only_dummies_ = FALSE;
7280 }
7281
7282 #endif
7283 /* ffecom_start_progunit_ -- Beginning of program unit
7284
7285    Does GNU back end stuff necessary to teach it about the start of its
7286    equivalent of a Fortran program unit.  */
7287
7288 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7289 static void
7290 ffecom_start_progunit_ ()
7291 {
7292   ffesymbol fn = ffecom_primary_entry_;
7293   ffebld arglist;
7294   tree id;                      /* Identifier (name) of function. */
7295   tree type;                    /* Type of function. */
7296   tree result;                  /* Result of function. */
7297   ffeinfoBasictype bt;
7298   ffeinfoKindtype kt;
7299   ffeglobal g;
7300   ffeglobalType gt;
7301   ffeglobalType egt = FFEGLOBAL_type;
7302   bool charfunc;
7303   bool cmplxfunc;
7304   bool altentries = (ffecom_num_entrypoints_ != 0);
7305   bool multi
7306   = altentries
7307   && (ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
7308   && (ffecom_master_bt_ == FFEINFO_basictypeNONE);
7309   bool main_program = FALSE;
7310   int old_lineno = lineno;
7311   char *old_input_filename = input_filename;
7312   int yes;
7313
7314   assert (fn != NULL);
7315   assert (ffesymbol_hook (fn).decl_tree == NULL_TREE);
7316
7317   input_filename = ffesymbol_where_filename (fn);
7318   lineno = ffesymbol_where_filelinenum (fn);
7319
7320   /* c-parse.y indeed does call suspend_momentary and not only ignores the
7321      return value, but also never calls resume_momentary, when starting an
7322      outer function (see "fndef:", "setspecs:", and so on).  So g77 does the
7323      same thing.  It shouldn't be a problem since start_function calls
7324      temporary_allocation, but it might be necessary.  If it causes a problem
7325      here, then maybe there's a bug lurking in gcc.  NOTE: This identical
7326      comment appears twice in thist file.  */
7327
7328   suspend_momentary ();
7329
7330   switch (ffecom_primary_entry_kind_)
7331     {
7332     case FFEINFO_kindPROGRAM:
7333       main_program = TRUE;
7334       gt = FFEGLOBAL_typeMAIN;
7335       bt = FFEINFO_basictypeNONE;
7336       kt = FFEINFO_kindtypeNONE;
7337       type = ffecom_tree_fun_type_void;
7338       charfunc = FALSE;
7339       cmplxfunc = FALSE;
7340       break;
7341
7342     case FFEINFO_kindBLOCKDATA:
7343       gt = FFEGLOBAL_typeBDATA;
7344       bt = FFEINFO_basictypeNONE;
7345       kt = FFEINFO_kindtypeNONE;
7346       type = ffecom_tree_fun_type_void;
7347       charfunc = FALSE;
7348       cmplxfunc = FALSE;
7349       break;
7350
7351     case FFEINFO_kindFUNCTION:
7352       gt = FFEGLOBAL_typeFUNC;
7353       egt = FFEGLOBAL_typeEXT;
7354       bt = ffesymbol_basictype (fn);
7355       kt = ffesymbol_kindtype (fn);
7356       if (bt == FFEINFO_basictypeNONE)
7357         {
7358           ffeimplic_establish_symbol (fn);
7359           if (ffesymbol_funcresult (fn) != NULL)
7360             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
7361           bt = ffesymbol_basictype (fn);
7362           kt = ffesymbol_kindtype (fn);
7363         }
7364
7365       if (multi)
7366         charfunc = cmplxfunc = FALSE;
7367       else if (bt == FFEINFO_basictypeCHARACTER)
7368         charfunc = TRUE, cmplxfunc = FALSE;
7369       else if ((bt == FFEINFO_basictypeCOMPLEX)
7370                && ffesymbol_is_f2c (fn)
7371                && !altentries)
7372         charfunc = FALSE, cmplxfunc = TRUE;
7373       else
7374         charfunc = cmplxfunc = FALSE;
7375
7376       if (multi || charfunc)
7377         type = ffecom_tree_fun_type_void;
7378       else if (ffesymbol_is_f2c (fn) && !altentries)
7379         type = ffecom_tree_fun_type[bt][kt];
7380       else
7381         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
7382
7383       if ((type == NULL_TREE)
7384           || (TREE_TYPE (type) == NULL_TREE))
7385         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
7386       break;
7387
7388     case FFEINFO_kindSUBROUTINE:
7389       gt = FFEGLOBAL_typeSUBR;
7390       egt = FFEGLOBAL_typeEXT;
7391       bt = FFEINFO_basictypeNONE;
7392       kt = FFEINFO_kindtypeNONE;
7393       if (ffecom_is_altreturning_)
7394         type = ffecom_tree_subr_type;
7395       else
7396         type = ffecom_tree_fun_type_void;
7397       charfunc = FALSE;
7398       cmplxfunc = FALSE;
7399       break;
7400
7401     default:
7402       assert ("say what??" == NULL);
7403       /* Fall through. */
7404     case FFEINFO_kindANY:
7405       gt = FFEGLOBAL_typeANY;
7406       bt = FFEINFO_basictypeNONE;
7407       kt = FFEINFO_kindtypeNONE;
7408       type = error_mark_node;
7409       charfunc = FALSE;
7410       cmplxfunc = FALSE;
7411       break;
7412     }
7413
7414   if (altentries)
7415     {
7416       id = ffecom_get_invented_identifier ("__g77_masterfun_%s",
7417                                            ffesymbol_text (fn),
7418                                            -1);
7419     }
7420 #if FFETARGET_isENFORCED_MAIN
7421   else if (main_program)
7422     id = get_identifier (FFETARGET_nameENFORCED_MAIN_NAME);
7423 #endif
7424   else
7425     id = ffecom_get_external_identifier_ (fn);
7426
7427   start_function (id,
7428                   type,
7429                   0,            /* nested/inline */
7430                   !altentries); /* TREE_PUBLIC */
7431
7432   TREE_USED (current_function_decl) = 1;        /* Avoid spurious warning if altentries. */
7433
7434   if (!altentries
7435       && ((g = ffesymbol_global (fn)) != NULL)
7436       && ((ffeglobal_type (g) == gt)
7437           || (ffeglobal_type (g) == egt)))
7438     {
7439       ffeglobal_set_hook (g, current_function_decl);
7440     }
7441
7442   yes = suspend_momentary ();
7443
7444   /* Arg handling needs exec-transitioned ffesymbols to work with.  But
7445      exec-transitioning needs current_function_decl to be filled in.  So we
7446      do these things in two phases. */
7447
7448   if (altentries)
7449     {                           /* 1st arg identifies which entrypoint. */
7450       ffecom_which_entrypoint_decl_
7451         = build_decl (PARM_DECL,
7452                       ffecom_get_invented_identifier ("__g77_%s",
7453                                                       "which_entrypoint",
7454                                                       -1),
7455                       integer_type_node);
7456       push_parm_decl (ffecom_which_entrypoint_decl_);
7457     }
7458
7459   if (charfunc
7460       || cmplxfunc
7461       || multi)
7462     {                           /* Arg for result (return value). */
7463       tree type;
7464       tree length;
7465
7466       if (charfunc)
7467         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
7468       else if (cmplxfunc)
7469         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
7470       else
7471         type = ffecom_multi_type_node_;
7472
7473       result = ffecom_get_invented_identifier ("__g77_%s",
7474                                                "result", -1);
7475
7476       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
7477
7478       if (charfunc)
7479         length = ffecom_char_enhance_arg_ (&type, fn);
7480       else
7481         length = NULL_TREE;     /* Not ref'd if !charfunc. */
7482
7483       type = build_pointer_type (type);
7484       result = build_decl (PARM_DECL, result, type);
7485
7486       push_parm_decl (result);
7487       if (multi)
7488         ffecom_multi_retval_ = result;
7489       else
7490         ffecom_func_result_ = result;
7491
7492       if (charfunc)
7493         {
7494           push_parm_decl (length);
7495           ffecom_func_length_ = length;
7496         }
7497     }
7498
7499   if (ffecom_primary_entry_is_proc_)
7500     {
7501       if (altentries)
7502         arglist = ffecom_master_arglist_;
7503       else
7504         arglist = ffesymbol_dummyargs (fn);
7505       ffecom_push_dummy_decls_ (arglist, FALSE);
7506     }
7507
7508   resume_momentary (yes);
7509
7510   if (TREE_CODE (current_function_decl) != ERROR_MARK)
7511     store_parm_decls (main_program ? 1 : 0);
7512
7513   ffecom_start_compstmt ();
7514   /* Disallow temp vars at this level.  */
7515   current_binding_level->prep_state = 2;
7516
7517   lineno = old_lineno;
7518   input_filename = old_input_filename;
7519
7520   /* This handles any symbols still untransformed, in case -g specified.
7521      This used to be done in ffecom_finish_progunit, but it turns out to
7522      be necessary to do it here so that statement functions are
7523      expanded before code.  But don't bother for BLOCK DATA.  */
7524
7525   if (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
7526     ffesymbol_drive (ffecom_finish_symbol_transform_);
7527 }
7528
7529 #endif
7530 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
7531
7532    ffesymbol s;
7533    ffecom_sym_transform_(s);
7534
7535    The ffesymbol_hook info for s is updated with appropriate backend info
7536    on the symbol.  */
7537
7538 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7539 static ffesymbol
7540 ffecom_sym_transform_ (ffesymbol s)
7541 {
7542   tree t;                       /* Transformed thingy. */
7543   tree tlen;                    /* Length if CHAR*(*). */
7544   bool addr;                    /* Is t the address of the thingy? */
7545   ffeinfoBasictype bt;
7546   ffeinfoKindtype kt;
7547   ffeglobal g;
7548   int yes;
7549   int old_lineno = lineno;
7550   char *old_input_filename = input_filename;
7551
7552   /* Must ensure special ASSIGN variables are declared at top of outermost
7553      block, else they'll end up in the innermost block when their first
7554      ASSIGN is seen, which leaves them out of scope when they're the
7555      subject of a GOTO or I/O statement.
7556
7557      We make this variable even if -fugly-assign.  Just let it go unused,
7558      in case it turns out there are cases where we really want to use this
7559      variable anyway (e.g. ASSIGN to INTEGER*2 variable).  */
7560
7561   if (! ffecom_transform_only_dummies_
7562       && ffesymbol_assigned (s)
7563       && ! ffesymbol_hook (s).assign_tree)
7564     s = ffecom_sym_transform_assign_ (s);
7565
7566   if (ffesymbol_sfdummyparent (s) == NULL)
7567     {
7568       input_filename = ffesymbol_where_filename (s);
7569       lineno = ffesymbol_where_filelinenum (s);
7570     }
7571   else
7572     {
7573       ffesymbol sf = ffesymbol_sfdummyparent (s);
7574
7575       input_filename = ffesymbol_where_filename (sf);
7576       lineno = ffesymbol_where_filelinenum (sf);
7577     }
7578
7579   bt = ffeinfo_basictype (ffebld_info (s));
7580   kt = ffeinfo_kindtype (ffebld_info (s));
7581
7582   t = NULL_TREE;
7583   tlen = NULL_TREE;
7584   addr = FALSE;
7585
7586   switch (ffesymbol_kind (s))
7587     {
7588     case FFEINFO_kindNONE:
7589       switch (ffesymbol_where (s))
7590         {
7591         case FFEINFO_whereDUMMY:        /* Subroutine or function. */
7592           assert (ffecom_transform_only_dummies_);
7593
7594           /* Before 0.4, this could be ENTITY/DUMMY, but see
7595              ffestu_sym_end_transition -- no longer true (in particular, if
7596              it could be an ENTITY, it _will_ be made one, so that
7597              possibility won't come through here).  So we never make length
7598              arg for CHARACTER type.  */
7599
7600           t = build_decl (PARM_DECL,
7601                           ffecom_get_identifier_ (ffesymbol_text (s)),
7602                           ffecom_tree_ptr_to_subr_type);
7603 #if BUILT_FOR_270
7604           DECL_ARTIFICIAL (t) = 1;
7605 #endif
7606           addr = TRUE;
7607           break;
7608
7609         case FFEINFO_whereGLOBAL:       /* Subroutine or function. */
7610           assert (!ffecom_transform_only_dummies_);
7611
7612           if (((g = ffesymbol_global (s)) != NULL)
7613               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7614                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7615                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
7616               && (ffeglobal_hook (g) != NULL_TREE)
7617               && ffe_is_globals ())
7618             {
7619               t = ffeglobal_hook (g);
7620               break;
7621             }
7622
7623           push_obstacks_nochange ();
7624           end_temporary_allocation ();
7625
7626           t = build_decl (FUNCTION_DECL,
7627                           ffecom_get_external_identifier_ (s),
7628                           ffecom_tree_subr_type);       /* Assume subr. */
7629           DECL_EXTERNAL (t) = 1;
7630           TREE_PUBLIC (t) = 1;
7631
7632           t = start_decl (t, FALSE);
7633           finish_decl (t, NULL_TREE, FALSE);
7634
7635           if ((g != NULL)
7636               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7637                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7638                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
7639             ffeglobal_set_hook (g, t);
7640
7641           resume_temporary_allocation ();
7642           pop_obstacks ();
7643
7644           break;
7645
7646         default:
7647           assert ("NONE where unexpected" == NULL);
7648           /* Fall through. */
7649         case FFEINFO_whereANY:
7650           break;
7651         }
7652       break;
7653
7654     case FFEINFO_kindENTITY:
7655       switch (ffeinfo_where (ffesymbol_info (s)))
7656         {
7657
7658         case FFEINFO_whereCONSTANT:
7659           /* ~~Debugging info needed? */
7660           assert (!ffecom_transform_only_dummies_);
7661           t = error_mark_node;  /* Shouldn't ever see this in expr. */
7662           break;
7663
7664         case FFEINFO_whereLOCAL:
7665           assert (!ffecom_transform_only_dummies_);
7666
7667           {
7668             ffestorag st = ffesymbol_storage (s);
7669             tree type;
7670
7671             if ((st != NULL)
7672                 && (ffestorag_size (st) == 0))
7673               {
7674                 t = error_mark_node;
7675                 break;
7676               }
7677
7678             yes = suspend_momentary ();
7679             type = ffecom_type_localvar_ (s, bt, kt);
7680             resume_momentary (yes);
7681
7682             if (type == error_mark_node)
7683               {
7684                 t = error_mark_node;
7685                 break;
7686               }
7687
7688             if ((st != NULL)
7689                 && (ffestorag_parent (st) != NULL))
7690               {                 /* Child of EQUIVALENCE parent. */
7691                 ffestorag est;
7692                 tree et;
7693                 int yes;
7694                 ffetargetOffset offset;
7695
7696                 est = ffestorag_parent (st);
7697                 ffecom_transform_equiv_ (est);
7698
7699                 et = ffestorag_hook (est);
7700                 assert (et != NULL_TREE);
7701
7702                 if (! TREE_STATIC (et))
7703                   put_var_into_stack (et);
7704
7705                 yes = suspend_momentary ();
7706
7707                 offset = ffestorag_modulo (est)
7708                   + ffestorag_offset (ffesymbol_storage (s))
7709                   - ffestorag_offset (est);
7710
7711                 ffecom_debug_kludge_ (et, "EQUIVALENCE", s, type, offset);
7712
7713                 /* (t_type *) (((char *) &et) + offset) */
7714
7715                 t = convert (string_type_node,  /* (char *) */
7716                              ffecom_1 (ADDR_EXPR,
7717                                        build_pointer_type (TREE_TYPE (et)),
7718                                        et));
7719                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
7720                               t,
7721                               build_int_2 (offset, 0));
7722                 t = convert (build_pointer_type (type),
7723                              t);
7724                 TREE_CONSTANT (t) = staticp (et);
7725
7726                 addr = TRUE;
7727
7728                 resume_momentary (yes);
7729               }
7730             else
7731               {
7732                 tree initexpr;
7733                 bool init = ffesymbol_is_init (s);
7734
7735                 yes = suspend_momentary ();
7736
7737                 t = build_decl (VAR_DECL,
7738                                 ffecom_get_identifier_ (ffesymbol_text (s)),
7739                                 type);
7740
7741                 if (init
7742                     || ffesymbol_namelisted (s)
7743 #ifdef FFECOM_sizeMAXSTACKITEM
7744                     || ((st != NULL)
7745                         && (ffestorag_size (st) > FFECOM_sizeMAXSTACKITEM))
7746 #endif
7747                     || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
7748                         && (ffecom_primary_entry_kind_
7749                             != FFEINFO_kindBLOCKDATA)
7750                         && (ffesymbol_is_save (s) || ffe_is_saveall ())))
7751                   TREE_STATIC (t) = !ffesymbol_attr (s, FFESYMBOL_attrADJUSTABLE);
7752                 else
7753                   TREE_STATIC (t) = 0;  /* No need to make static. */
7754
7755                 if (init || ffe_is_init_local_zero ())
7756                   DECL_INITIAL (t) = error_mark_node;
7757
7758                 /* Keep -Wunused from complaining about var if it
7759                    is used as sfunc arg or DATA implied-DO.  */
7760                 if (ffesymbol_attrs (s) & FFESYMBOL_attrsSFARG)
7761                   DECL_IN_SYSTEM_HEADER (t) = 1;
7762
7763                 t = start_decl (t, FALSE);
7764
7765                 if (init)
7766                   {
7767                     if (ffesymbol_init (s) != NULL)
7768                       initexpr = ffecom_expr (ffesymbol_init (s));
7769                     else
7770                       initexpr = ffecom_init_zero_ (t);
7771                   }
7772                 else if (ffe_is_init_local_zero ())
7773                   initexpr = ffecom_init_zero_ (t);
7774                 else
7775                   initexpr = NULL_TREE; /* Not ref'd if !init. */
7776
7777                 finish_decl (t, initexpr, FALSE);
7778
7779                 if ((st != NULL) && (DECL_SIZE (t) != error_mark_node))
7780                   {
7781                     tree size_tree;
7782
7783                     size_tree = size_binop (CEIL_DIV_EXPR,
7784                                             DECL_SIZE (t),
7785                                             size_int (BITS_PER_UNIT));
7786                     assert (TREE_INT_CST_HIGH (size_tree) == 0);
7787                     assert (TREE_INT_CST_LOW (size_tree) == ffestorag_size (st));
7788                   }
7789
7790                 resume_momentary (yes);
7791               }
7792           }
7793           break;
7794
7795         case FFEINFO_whereRESULT:
7796           assert (!ffecom_transform_only_dummies_);
7797
7798           if (bt == FFEINFO_basictypeCHARACTER)
7799             {                   /* Result is already in list of dummies, use
7800                                    it (& length). */
7801               t = ffecom_func_result_;
7802               tlen = ffecom_func_length_;
7803               addr = TRUE;
7804               break;
7805             }
7806           if ((ffecom_num_entrypoints_ == 0)
7807               && (bt == FFEINFO_basictypeCOMPLEX)
7808               && (ffesymbol_is_f2c (ffecom_primary_entry_)))
7809             {                   /* Result is already in list of dummies, use
7810                                    it. */
7811               t = ffecom_func_result_;
7812               addr = TRUE;
7813               break;
7814             }
7815           if (ffecom_func_result_ != NULL_TREE)
7816             {
7817               t = ffecom_func_result_;
7818               break;
7819             }
7820           if ((ffecom_num_entrypoints_ != 0)
7821               && (ffecom_master_bt_ == FFEINFO_basictypeNONE))
7822             {
7823               yes = suspend_momentary ();
7824
7825               assert (ffecom_multi_retval_ != NULL_TREE);
7826               t = ffecom_1 (INDIRECT_REF, ffecom_multi_type_node_,
7827                             ffecom_multi_retval_);
7828               t = ffecom_2 (COMPONENT_REF, ffecom_tree_type[bt][kt],
7829                             t, ffecom_multi_fields_[bt][kt]);
7830
7831               resume_momentary (yes);
7832               break;
7833             }
7834
7835           yes = suspend_momentary ();
7836
7837           t = build_decl (VAR_DECL,
7838                           ffecom_get_identifier_ (ffesymbol_text (s)),
7839                           ffecom_tree_type[bt][kt]);
7840           TREE_STATIC (t) = 0;  /* Put result on stack. */
7841           t = start_decl (t, FALSE);
7842           finish_decl (t, NULL_TREE, FALSE);
7843
7844           ffecom_func_result_ = t;
7845
7846           resume_momentary (yes);
7847           break;
7848
7849         case FFEINFO_whereDUMMY:
7850           {
7851             tree type;
7852             ffebld dl;
7853             ffebld dim;
7854             tree low;
7855             tree high;
7856             tree old_sizes;
7857             bool adjustable = FALSE;    /* Conditionally adjustable? */
7858
7859             type = ffecom_tree_type[bt][kt];
7860             if (ffesymbol_sfdummyparent (s) != NULL)
7861               {
7862                 if (current_function_decl == ffecom_outer_function_decl_)
7863                   {                     /* Exec transition before sfunc
7864                                            context; get it later. */
7865                     break;
7866                   }
7867                 t = ffecom_get_identifier_ (ffesymbol_text
7868                                             (ffesymbol_sfdummyparent (s)));
7869               }
7870             else
7871               t = ffecom_get_identifier_ (ffesymbol_text (s));
7872
7873             assert (ffecom_transform_only_dummies_);
7874
7875             old_sizes = get_pending_sizes ();
7876             put_pending_sizes (old_sizes);
7877
7878             if (bt == FFEINFO_basictypeCHARACTER)
7879               tlen = ffecom_char_enhance_arg_ (&type, s);
7880             type = ffecom_check_size_overflow_ (s, type, TRUE);
7881
7882             for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
7883               {
7884                 if (type == error_mark_node)
7885                   break;
7886
7887                 dim = ffebld_head (dl);
7888                 assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
7889                 if ((ffebld_left (dim) == NULL) || ffecom_doing_entry_)
7890                   low = ffecom_integer_one_node;
7891                 else
7892                   low = ffecom_expr (ffebld_left (dim));
7893                 assert (ffebld_right (dim) != NULL);
7894                 if ((ffebld_op (ffebld_right (dim)) == FFEBLD_opSTAR)
7895                     || ffecom_doing_entry_)
7896                   {
7897                     /* Used to just do high=low.  But for ffecom_tree_
7898                        canonize_ref_, it probably is important to correctly
7899                        assess the size.  E.g. given COMPLEX C(*),CFUNC and
7900                        C(2)=CFUNC(C), overlap can happen, while it can't
7901                        for, say, C(1)=CFUNC(C(2)).  */
7902                     /* Even more recently used to set to INT_MAX, but that
7903                        broke when some overflow checking went into the back
7904                        end.  Now we just leave the upper bound unspecified.  */
7905                     high = NULL;
7906                   }
7907                 else
7908                   high = ffecom_expr (ffebld_right (dim));
7909
7910                 /* Determine whether array is conditionally adjustable,
7911                    to decide whether back-end magic is needed.
7912
7913                    Normally the front end uses the back-end function
7914                    variable_size to wrap SAVE_EXPR's around expressions
7915                    affecting the size/shape of an array so that the
7916                    size/shape info doesn't change during execution
7917                    of the compiled code even though variables and
7918                    functions referenced in those expressions might.
7919
7920                    variable_size also makes sure those saved expressions
7921                    get evaluated immediately upon entry to the
7922                    compiled procedure -- the front end normally doesn't
7923                    have to worry about that.
7924
7925                    However, there is a problem with this that affects
7926                    g77's implementation of entry points, and that is
7927                    that it is _not_ true that each invocation of the
7928                    compiled procedure is permitted to evaluate
7929                    array size/shape info -- because it is possible
7930                    that, for some invocations, that info is invalid (in
7931                    which case it is "promised" -- i.e. a violation of
7932                    the Fortran standard -- that the compiled code
7933                    won't reference the array or its size/shape
7934                    during that particular invocation).
7935
7936                    To phrase this in C terms, consider this gcc function:
7937
7938                      void foo (int *n, float (*a)[*n])
7939                      {
7940                        // a is "pointer to array ...", fyi.
7941                      }
7942
7943                    Suppose that, for some invocations, it is permitted
7944                    for a caller of foo to do this:
7945
7946                        foo (NULL, NULL);
7947
7948                    Now the _written_ code for foo can take such a call
7949                    into account by either testing explicitly for whether
7950                    (a == NULL) || (n == NULL) -- presumably it is
7951                    not permitted to reference *a in various fashions
7952                    if (n == NULL) I suppose -- or it can avoid it by
7953                    looking at other info (other arguments, static/global
7954                    data, etc.).
7955
7956                    However, this won't work in gcc 2.5.8 because it'll
7957                    automatically emit the code to save the "*n"
7958                    expression, which'll yield a NULL dereference for
7959                    the "foo (NULL, NULL)" call, something the code
7960                    for foo cannot prevent.
7961
7962                    g77 definitely needs to avoid executing such
7963                    code anytime the pointer to the adjustable array
7964                    is NULL, because even if its bounds expressions
7965                    don't have any references to possible "absent"
7966                    variables like "*n" -- say all variable references
7967                    are to COMMON variables, i.e. global (though in C,
7968                    local static could actually make sense) -- the
7969                    expressions could yield other run-time problems
7970                    for allowably "dead" values in those variables.
7971
7972                    For example, let's consider a more complicated
7973                    version of foo:
7974
7975                      extern int i;
7976                      extern int j;
7977
7978                      void foo (float (*a)[i/j])
7979                      {
7980                        ...
7981                      }
7982
7983                    The above is (essentially) quite valid for Fortran
7984                    but, again, for a call like "foo (NULL);", it is
7985                    permitted for i and j to be undefined when the
7986                    call is made.  If j happened to be zero, for
7987                    example, emitting the code to evaluate "i/j"
7988                    could result in a run-time error.
7989
7990                    Offhand, though I don't have my F77 or F90
7991                    standards handy, it might even be valid for a
7992                    bounds expression to contain a function reference,
7993                    in which case I doubt it is permitted for an
7994                    implementation to invoke that function in the
7995                    Fortran case involved here (invocation of an
7996                    alternate ENTRY point that doesn't have the adjustable
7997                    array as one of its arguments).
7998
7999                    So, the code that the compiler would normally emit
8000                    to preevaluate the size/shape info for an
8001                    adjustable array _must not_ be executed at run time
8002                    in certain cases.  Specifically, for Fortran,
8003                    the case is when the pointer to the adjustable
8004                    array == NULL.  (For gnu-ish C, it might be nice
8005                    for the source code itself to specify an expression
8006                    that, if TRUE, inhibits execution of the code.  Or
8007                    reverse the sense for elegance.)
8008
8009                    (Note that g77 could use a different test than NULL,
8010                    actually, since it happens to always pass an
8011                    integer to the called function that specifies which
8012                    entry point is being invoked.  Hmm, this might
8013                    solve the next problem.)
8014
8015                    One way a user could, I suppose, write "foo" so
8016                    it works is to insert COND_EXPR's for the
8017                    size/shape info so the dangerous stuff isn't
8018                    actually done, as in:
8019
8020                      void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
8021                      {
8022                        ...
8023                      }
8024
8025                    The next problem is that the front end needs to
8026                    be able to tell the back end about the array's
8027                    decl _before_ it tells it about the conditional
8028                    expression to inhibit evaluation of size/shape info,
8029                    as shown above.
8030
8031                    To solve this, the front end needs to be able
8032                    to give the back end the expression to inhibit
8033                    generation of the preevaluation code _after_
8034                    it makes the decl for the adjustable array.
8035
8036                    Until then, the above example using the COND_EXPR
8037                    doesn't pass muster with gcc because the "(a == NULL)"
8038                    part has a reference to "a", which is still
8039                    undefined at that point.
8040
8041                    g77 will therefore use a different mechanism in the
8042                    meantime.  */
8043
8044                 if (!adjustable
8045                     && ((TREE_CODE (low) != INTEGER_CST)
8046                         || (high && TREE_CODE (high) != INTEGER_CST)))
8047                   adjustable = TRUE;
8048
8049 #if 0                           /* Old approach -- see below. */
8050                 if (TREE_CODE (low) != INTEGER_CST)
8051                   low = ffecom_3 (COND_EXPR, integer_type_node,
8052                                   ffecom_adjarray_passed_ (s),
8053                                   low,
8054                                   ffecom_integer_zero_node);
8055
8056                 if (high && TREE_CODE (high) != INTEGER_CST)
8057                   high = ffecom_3 (COND_EXPR, integer_type_node,
8058                                    ffecom_adjarray_passed_ (s),
8059                                    high,
8060                                    ffecom_integer_zero_node);
8061 #endif
8062
8063                 /* ~~~gcc/stor-layout.c (layout_type) should do this,
8064                    probably.  Fixes 950302-1.f.  */
8065
8066                 if (TREE_CODE (low) != INTEGER_CST)
8067                   low = variable_size (low);
8068
8069                 /* ~~~Similarly, this fixes dumb0.f.  The C front end
8070                    does this, which is why dumb0.c would work.  */
8071
8072                 if (high && TREE_CODE (high) != INTEGER_CST)
8073                   high = variable_size (high);
8074
8075                 type
8076                   = build_array_type
8077                     (type,
8078                      build_range_type (ffecom_integer_type_node,
8079                                        low, high));
8080                 type = ffecom_check_size_overflow_ (s, type, TRUE);
8081               }
8082
8083             if (type == error_mark_node)
8084               {
8085                 t = error_mark_node;
8086                 break;
8087               }
8088
8089             if ((ffesymbol_sfdummyparent (s) == NULL)
8090                  || (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
8091               {
8092                 type = build_pointer_type (type);
8093                 addr = TRUE;
8094               }
8095
8096             t = build_decl (PARM_DECL, t, type);
8097 #if BUILT_FOR_270
8098             DECL_ARTIFICIAL (t) = 1;
8099 #endif
8100
8101             /* If this arg is present in every entry point's list of
8102                dummy args, then we're done.  */
8103
8104             if (ffesymbol_numentries (s)
8105                 == (ffecom_num_entrypoints_ + 1))
8106               break;
8107
8108 #if 1
8109
8110             /* If variable_size in stor-layout has been called during
8111                the above, then get_pending_sizes should have the
8112                yet-to-be-evaluated saved expressions pending.
8113                Make the whole lot of them get emitted, conditionally
8114                on whether the array decl ("t" above) is not NULL.  */
8115
8116             {
8117               tree sizes = get_pending_sizes ();
8118               tree tem;
8119
8120               for (tem = sizes;
8121                    tem != old_sizes;
8122                    tem = TREE_CHAIN (tem))
8123                 {
8124                   tree temv = TREE_VALUE (tem);
8125
8126                   if (sizes == tem)
8127                     sizes = temv;
8128                   else
8129                     sizes
8130                       = ffecom_2 (COMPOUND_EXPR,
8131                                   TREE_TYPE (sizes),
8132                                   temv,
8133                                   sizes);
8134                 }
8135
8136               if (sizes != tem)
8137                 {
8138                   sizes
8139                     = ffecom_3 (COND_EXPR,
8140                                 TREE_TYPE (sizes),
8141                                 ffecom_2 (NE_EXPR,
8142                                           integer_type_node,
8143                                           t,
8144                                           null_pointer_node),
8145                                 sizes,
8146                                 convert (TREE_TYPE (sizes),
8147                                          integer_zero_node));
8148                   sizes = ffecom_save_tree (sizes);
8149
8150                   sizes
8151                     = tree_cons (NULL_TREE, sizes, tem);
8152                 }
8153
8154               if (sizes)
8155                 put_pending_sizes (sizes);
8156             }
8157
8158 #else
8159 #if 0
8160             if (adjustable
8161                 && (ffesymbol_numentries (s)
8162                     != ffecom_num_entrypoints_ + 1))
8163               DECL_SOMETHING (t)
8164                 = ffecom_2 (NE_EXPR, integer_type_node,
8165                             t,
8166                             null_pointer_node);
8167 #else
8168 #if 0
8169             if (adjustable
8170                 && (ffesymbol_numentries (s)
8171                     != ffecom_num_entrypoints_ + 1))
8172               {
8173                 ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED);
8174                 ffebad_here (0, ffesymbol_where_line (s),
8175                              ffesymbol_where_column (s));
8176                 ffebad_string (ffesymbol_text (s));
8177                 ffebad_finish ();
8178               }
8179 #endif
8180 #endif
8181 #endif
8182           }
8183           break;
8184
8185         case FFEINFO_whereCOMMON:
8186           {
8187             ffesymbol cs;
8188             ffeglobal cg;
8189             tree ct;
8190             ffestorag st = ffesymbol_storage (s);
8191             tree type;
8192             int yes;
8193
8194             cs = ffesymbol_common (s);  /* The COMMON area itself.  */
8195             if (st != NULL)     /* Else not laid out. */
8196               {
8197                 ffecom_transform_common_ (cs);
8198                 st = ffesymbol_storage (s);
8199               }
8200
8201             yes = suspend_momentary ();
8202
8203             type = ffecom_type_localvar_ (s, bt, kt);
8204
8205             cg = ffesymbol_global (cs); /* The global COMMON info.  */
8206             if ((cg == NULL)
8207                 || (ffeglobal_type (cg) != FFEGLOBAL_typeCOMMON))
8208               ct = NULL_TREE;
8209             else
8210               ct = ffeglobal_hook (cg); /* The common area's tree.  */
8211
8212             if ((ct == NULL_TREE)
8213                 || (st == NULL)
8214                 || (type == error_mark_node))
8215               t = error_mark_node;
8216             else
8217               {
8218                 ffetargetOffset offset;
8219                 ffestorag cst;
8220
8221                 cst = ffestorag_parent (st);
8222                 assert (cst == ffesymbol_storage (cs));
8223
8224                 offset = ffestorag_modulo (cst)
8225                   + ffestorag_offset (st)
8226                   - ffestorag_offset (cst);
8227
8228                 ffecom_debug_kludge_ (ct, "COMMON", s, type, offset);
8229
8230                 /* (t_type *) (((char *) &ct) + offset) */
8231
8232                 t = convert (string_type_node,  /* (char *) */
8233                              ffecom_1 (ADDR_EXPR,
8234                                        build_pointer_type (TREE_TYPE (ct)),
8235                                        ct));
8236                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
8237                               t,
8238                               build_int_2 (offset, 0));
8239                 t = convert (build_pointer_type (type),
8240                              t);
8241                 TREE_CONSTANT (t) = 1;
8242
8243                 addr = TRUE;
8244               }
8245
8246             resume_momentary (yes);
8247           }
8248           break;
8249
8250         case FFEINFO_whereIMMEDIATE:
8251         case FFEINFO_whereGLOBAL:
8252         case FFEINFO_whereFLEETING:
8253         case FFEINFO_whereFLEETING_CADDR:
8254         case FFEINFO_whereFLEETING_IADDR:
8255         case FFEINFO_whereINTRINSIC:
8256         case FFEINFO_whereCONSTANT_SUBOBJECT:
8257         default:
8258           assert ("ENTITY where unheard of" == NULL);
8259           /* Fall through. */
8260         case FFEINFO_whereANY:
8261           t = error_mark_node;
8262           break;
8263         }
8264       break;
8265
8266     case FFEINFO_kindFUNCTION:
8267       switch (ffeinfo_where (ffesymbol_info (s)))
8268         {
8269         case FFEINFO_whereLOCAL:        /* Me. */
8270           assert (!ffecom_transform_only_dummies_);
8271           t = current_function_decl;
8272           break;
8273
8274         case FFEINFO_whereGLOBAL:
8275           assert (!ffecom_transform_only_dummies_);
8276
8277           if (((g = ffesymbol_global (s)) != NULL)
8278               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8279                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8280               && (ffeglobal_hook (g) != NULL_TREE)
8281               && ffe_is_globals ())
8282             {
8283               t = ffeglobal_hook (g);
8284               break;
8285             }
8286
8287           push_obstacks_nochange ();
8288           end_temporary_allocation ();
8289
8290           if (ffesymbol_is_f2c (s)
8291               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8292             t = ffecom_tree_fun_type[bt][kt];
8293           else
8294             t = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
8295
8296           t = build_decl (FUNCTION_DECL,
8297                           ffecom_get_external_identifier_ (s),
8298                           t);
8299           DECL_EXTERNAL (t) = 1;
8300           TREE_PUBLIC (t) = 1;
8301
8302           t = start_decl (t, FALSE);
8303           finish_decl (t, NULL_TREE, FALSE);
8304
8305           if ((g != NULL)
8306               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8307                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8308             ffeglobal_set_hook (g, t);
8309
8310           resume_temporary_allocation ();
8311           pop_obstacks ();
8312
8313           break;
8314
8315         case FFEINFO_whereDUMMY:
8316           assert (ffecom_transform_only_dummies_);
8317
8318           if (ffesymbol_is_f2c (s)
8319               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8320             t = ffecom_tree_ptr_to_fun_type[bt][kt];
8321           else
8322             t = build_pointer_type
8323               (build_function_type (ffecom_tree_type[bt][kt], NULL_TREE));
8324
8325           t = build_decl (PARM_DECL,
8326                           ffecom_get_identifier_ (ffesymbol_text (s)),
8327                           t);
8328 #if BUILT_FOR_270
8329           DECL_ARTIFICIAL (t) = 1;
8330 #endif
8331           addr = TRUE;
8332           break;
8333
8334         case FFEINFO_whereCONSTANT:     /* Statement function. */
8335           assert (!ffecom_transform_only_dummies_);
8336           t = ffecom_gen_sfuncdef_ (s, bt, kt);
8337           break;
8338
8339         case FFEINFO_whereINTRINSIC:
8340           assert (!ffecom_transform_only_dummies_);
8341           break;                /* Let actual references generate their
8342                                    decls. */
8343
8344         default:
8345           assert ("FUNCTION where unheard of" == NULL);
8346           /* Fall through. */
8347         case FFEINFO_whereANY:
8348           t = error_mark_node;
8349           break;
8350         }
8351       break;
8352
8353     case FFEINFO_kindSUBROUTINE:
8354       switch (ffeinfo_where (ffesymbol_info (s)))
8355         {
8356         case FFEINFO_whereLOCAL:        /* Me. */
8357           assert (!ffecom_transform_only_dummies_);
8358           t = current_function_decl;
8359           break;
8360
8361         case FFEINFO_whereGLOBAL:
8362           assert (!ffecom_transform_only_dummies_);
8363
8364           if (((g = ffesymbol_global (s)) != NULL)
8365               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8366                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8367               && (ffeglobal_hook (g) != NULL_TREE)
8368               && ffe_is_globals ())
8369             {
8370               t = ffeglobal_hook (g);
8371               break;
8372             }
8373
8374           push_obstacks_nochange ();
8375           end_temporary_allocation ();
8376
8377           t = build_decl (FUNCTION_DECL,
8378                           ffecom_get_external_identifier_ (s),
8379                           ffecom_tree_subr_type);
8380           DECL_EXTERNAL (t) = 1;
8381           TREE_PUBLIC (t) = 1;
8382
8383           t = start_decl (t, FALSE);
8384           finish_decl (t, NULL_TREE, FALSE);
8385
8386           if ((g != NULL)
8387               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8388                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8389             ffeglobal_set_hook (g, t);
8390
8391           resume_temporary_allocation ();
8392           pop_obstacks ();
8393
8394           break;
8395
8396         case FFEINFO_whereDUMMY:
8397           assert (ffecom_transform_only_dummies_);
8398
8399           t = build_decl (PARM_DECL,
8400                           ffecom_get_identifier_ (ffesymbol_text (s)),
8401                           ffecom_tree_ptr_to_subr_type);
8402 #if BUILT_FOR_270
8403           DECL_ARTIFICIAL (t) = 1;
8404 #endif
8405           addr = TRUE;
8406           break;
8407
8408         case FFEINFO_whereINTRINSIC:
8409           assert (!ffecom_transform_only_dummies_);
8410           break;                /* Let actual references generate their
8411                                    decls. */
8412
8413         default:
8414           assert ("SUBROUTINE where unheard of" == NULL);
8415           /* Fall through. */
8416         case FFEINFO_whereANY:
8417           t = error_mark_node;
8418           break;
8419         }
8420       break;
8421
8422     case FFEINFO_kindPROGRAM:
8423       switch (ffeinfo_where (ffesymbol_info (s)))
8424         {
8425         case FFEINFO_whereLOCAL:        /* Me. */
8426           assert (!ffecom_transform_only_dummies_);
8427           t = current_function_decl;
8428           break;
8429
8430         case FFEINFO_whereCOMMON:
8431         case FFEINFO_whereDUMMY:
8432         case FFEINFO_whereGLOBAL:
8433         case FFEINFO_whereRESULT:
8434         case FFEINFO_whereFLEETING:
8435         case FFEINFO_whereFLEETING_CADDR:
8436         case FFEINFO_whereFLEETING_IADDR:
8437         case FFEINFO_whereIMMEDIATE:
8438         case FFEINFO_whereINTRINSIC:
8439         case FFEINFO_whereCONSTANT:
8440         case FFEINFO_whereCONSTANT_SUBOBJECT:
8441         default:
8442           assert ("PROGRAM where unheard of" == NULL);
8443           /* Fall through. */
8444         case FFEINFO_whereANY:
8445           t = error_mark_node;
8446           break;
8447         }
8448       break;
8449
8450     case FFEINFO_kindBLOCKDATA:
8451       switch (ffeinfo_where (ffesymbol_info (s)))
8452         {
8453         case FFEINFO_whereLOCAL:        /* Me. */
8454           assert (!ffecom_transform_only_dummies_);
8455           t = current_function_decl;
8456           break;
8457
8458         case FFEINFO_whereGLOBAL:
8459           assert (!ffecom_transform_only_dummies_);
8460
8461           push_obstacks_nochange ();
8462           end_temporary_allocation ();
8463
8464           t = build_decl (FUNCTION_DECL,
8465                           ffecom_get_external_identifier_ (s),
8466                           ffecom_tree_blockdata_type);
8467           DECL_EXTERNAL (t) = 1;
8468           TREE_PUBLIC (t) = 1;
8469
8470           t = start_decl (t, FALSE);
8471           finish_decl (t, NULL_TREE, FALSE);
8472
8473           resume_temporary_allocation ();
8474           pop_obstacks ();
8475
8476           break;
8477
8478         case FFEINFO_whereCOMMON:
8479         case FFEINFO_whereDUMMY:
8480         case FFEINFO_whereRESULT:
8481         case FFEINFO_whereFLEETING:
8482         case FFEINFO_whereFLEETING_CADDR:
8483         case FFEINFO_whereFLEETING_IADDR:
8484         case FFEINFO_whereIMMEDIATE:
8485         case FFEINFO_whereINTRINSIC:
8486         case FFEINFO_whereCONSTANT:
8487         case FFEINFO_whereCONSTANT_SUBOBJECT:
8488         default:
8489           assert ("BLOCKDATA where unheard of" == NULL);
8490           /* Fall through. */
8491         case FFEINFO_whereANY:
8492           t = error_mark_node;
8493           break;
8494         }
8495       break;
8496
8497     case FFEINFO_kindCOMMON:
8498       switch (ffeinfo_where (ffesymbol_info (s)))
8499         {
8500         case FFEINFO_whereLOCAL:
8501           assert (!ffecom_transform_only_dummies_);
8502           ffecom_transform_common_ (s);
8503           break;
8504
8505         case FFEINFO_whereNONE:
8506         case FFEINFO_whereCOMMON:
8507         case FFEINFO_whereDUMMY:
8508         case FFEINFO_whereGLOBAL:
8509         case FFEINFO_whereRESULT:
8510         case FFEINFO_whereFLEETING:
8511         case FFEINFO_whereFLEETING_CADDR:
8512         case FFEINFO_whereFLEETING_IADDR:
8513         case FFEINFO_whereIMMEDIATE:
8514         case FFEINFO_whereINTRINSIC:
8515         case FFEINFO_whereCONSTANT:
8516         case FFEINFO_whereCONSTANT_SUBOBJECT:
8517         default:
8518           assert ("COMMON where unheard of" == NULL);
8519           /* Fall through. */
8520         case FFEINFO_whereANY:
8521           t = error_mark_node;
8522           break;
8523         }
8524       break;
8525
8526     case FFEINFO_kindCONSTRUCT:
8527       switch (ffeinfo_where (ffesymbol_info (s)))
8528         {
8529         case FFEINFO_whereLOCAL:
8530           assert (!ffecom_transform_only_dummies_);
8531           break;
8532
8533         case FFEINFO_whereNONE:
8534         case FFEINFO_whereCOMMON:
8535         case FFEINFO_whereDUMMY:
8536         case FFEINFO_whereGLOBAL:
8537         case FFEINFO_whereRESULT:
8538         case FFEINFO_whereFLEETING:
8539         case FFEINFO_whereFLEETING_CADDR:
8540         case FFEINFO_whereFLEETING_IADDR:
8541         case FFEINFO_whereIMMEDIATE:
8542         case FFEINFO_whereINTRINSIC:
8543         case FFEINFO_whereCONSTANT:
8544         case FFEINFO_whereCONSTANT_SUBOBJECT:
8545         default:
8546           assert ("CONSTRUCT where unheard of" == NULL);
8547           /* Fall through. */
8548         case FFEINFO_whereANY:
8549           t = error_mark_node;
8550           break;
8551         }
8552       break;
8553
8554     case FFEINFO_kindNAMELIST:
8555       switch (ffeinfo_where (ffesymbol_info (s)))
8556         {
8557         case FFEINFO_whereLOCAL:
8558           assert (!ffecom_transform_only_dummies_);
8559           t = ffecom_transform_namelist_ (s);
8560           break;
8561
8562         case FFEINFO_whereNONE:
8563         case FFEINFO_whereCOMMON:
8564         case FFEINFO_whereDUMMY:
8565         case FFEINFO_whereGLOBAL:
8566         case FFEINFO_whereRESULT:
8567         case FFEINFO_whereFLEETING:
8568         case FFEINFO_whereFLEETING_CADDR:
8569         case FFEINFO_whereFLEETING_IADDR:
8570         case FFEINFO_whereIMMEDIATE:
8571         case FFEINFO_whereINTRINSIC:
8572         case FFEINFO_whereCONSTANT:
8573         case FFEINFO_whereCONSTANT_SUBOBJECT:
8574         default:
8575           assert ("NAMELIST where unheard of" == NULL);
8576           /* Fall through. */
8577         case FFEINFO_whereANY:
8578           t = error_mark_node;
8579           break;
8580         }
8581       break;
8582
8583     default:
8584       assert ("kind unheard of" == NULL);
8585       /* Fall through. */
8586     case FFEINFO_kindANY:
8587       t = error_mark_node;
8588       break;
8589     }
8590
8591   ffesymbol_hook (s).decl_tree = t;
8592   ffesymbol_hook (s).length_tree = tlen;
8593   ffesymbol_hook (s).addr = addr;
8594
8595   lineno = old_lineno;
8596   input_filename = old_input_filename;
8597
8598   return s;
8599 }
8600
8601 #endif
8602 /* Transform into ASSIGNable symbol.
8603
8604    Symbol has already been transformed, but for whatever reason, the
8605    resulting decl_tree has been deemed not usable for an ASSIGN target.
8606    (E.g. it isn't wide enough to hold a pointer.)  So, here we invent
8607    another local symbol of type void * and stuff that in the assign_tree
8608    argument.  The F77/F90 standards allow this implementation.  */
8609
8610 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8611 static ffesymbol
8612 ffecom_sym_transform_assign_ (ffesymbol s)
8613 {
8614   tree t;                       /* Transformed thingy. */
8615   int yes;
8616   int old_lineno = lineno;
8617   char *old_input_filename = input_filename;
8618
8619   if (ffesymbol_sfdummyparent (s) == NULL)
8620     {
8621       input_filename = ffesymbol_where_filename (s);
8622       lineno = ffesymbol_where_filelinenum (s);
8623     }
8624   else
8625     {
8626       ffesymbol sf = ffesymbol_sfdummyparent (s);
8627
8628       input_filename = ffesymbol_where_filename (sf);
8629       lineno = ffesymbol_where_filelinenum (sf);
8630     }
8631
8632   assert (!ffecom_transform_only_dummies_);
8633
8634   yes = suspend_momentary ();
8635
8636   t = build_decl (VAR_DECL,
8637                   ffecom_get_invented_identifier ("__g77_ASSIGN_%s",
8638                                                    ffesymbol_text (s),
8639                                                    -1),
8640                   TREE_TYPE (null_pointer_node));
8641
8642   switch (ffesymbol_where (s))
8643     {
8644     case FFEINFO_whereLOCAL:
8645       /* Unlike for regular vars, SAVE status is easy to determine for
8646          ASSIGNed vars, since there's no initialization, there's no
8647          effective storage association (so "SAVE J" does not apply to
8648          K even given "EQUIVALENCE (J,K)"), there's no size issue
8649          to worry about, etc.  */
8650       if ((ffesymbol_is_save (s) || ffe_is_saveall ())
8651           && (ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8652           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA))
8653         TREE_STATIC (t) = 1;    /* SAVEd in proc, make static. */
8654       else
8655         TREE_STATIC (t) = 0;    /* No need to make static. */
8656       break;
8657
8658     case FFEINFO_whereCOMMON:
8659       TREE_STATIC (t) = 1;      /* Assume COMMONs always SAVEd. */
8660       break;
8661
8662     case FFEINFO_whereDUMMY:
8663       /* Note that twinning a DUMMY means the caller won't see
8664          the ASSIGNed value.  But both F77 and F90 allow implementations
8665          to do this, i.e. disallow Fortran code that would try and
8666          take advantage of actually putting a label into a variable
8667          via a dummy argument (or any other storage association, for
8668          that matter).  */
8669       TREE_STATIC (t) = 0;
8670       break;
8671
8672     default:
8673       TREE_STATIC (t) = 0;
8674       break;
8675     }
8676
8677   t = start_decl (t, FALSE);
8678   finish_decl (t, NULL_TREE, FALSE);
8679
8680   resume_momentary (yes);
8681
8682   ffesymbol_hook (s).assign_tree = t;
8683
8684   lineno = old_lineno;
8685   input_filename = old_input_filename;
8686
8687   return s;
8688 }
8689
8690 #endif
8691 /* Implement COMMON area in back end.
8692
8693    Because COMMON-based variables can be referenced in the dimension
8694    expressions of dummy (adjustable) arrays, and because dummies
8695    (in the gcc back end) need to be put in the outer binding level
8696    of a function (which has two binding levels, the outer holding
8697    the dummies and the inner holding the other vars), special care
8698    must be taken to handle COMMON areas.
8699
8700    The current strategy is basically to always tell the back end about
8701    the COMMON area as a top-level external reference to just a block
8702    of storage of the master type of that area (e.g. integer, real,
8703    character, whatever -- not a structure).  As a distinct action,
8704    if initial values are provided, tell the back end about the area
8705    as a top-level non-external (initialized) area and remember not to
8706    allow further initialization or expansion of the area.  Meanwhile,
8707    if no initialization happens at all, tell the back end about
8708    the largest size we've seen declared so the space does get reserved.
8709    (This function doesn't handle all that stuff, but it does some
8710    of the important things.)
8711
8712    Meanwhile, for COMMON variables themselves, just keep creating
8713    references like *((float *) (&common_area + offset)) each time
8714    we reference the variable.  In other words, don't make a VAR_DECL
8715    or any kind of component reference (like we used to do before 0.4),
8716    though we might do that as well just for debugging purposes (and
8717    stuff the rtl with the appropriate offset expression).  */
8718
8719 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8720 static void
8721 ffecom_transform_common_ (ffesymbol s)
8722 {
8723   ffestorag st = ffesymbol_storage (s);
8724   ffeglobal g = ffesymbol_global (s);
8725   tree cbt;
8726   tree cbtype;
8727   tree init;
8728   tree high;
8729   bool is_init = ffestorag_is_init (st);
8730
8731   assert (st != NULL);
8732
8733   if ((g == NULL)
8734       || (ffeglobal_type (g) != FFEGLOBAL_typeCOMMON))
8735     return;
8736
8737   /* First update the size of the area in global terms.  */
8738
8739   ffeglobal_size_common (s, ffestorag_size (st));
8740
8741   if (!ffeglobal_common_init (g))
8742     is_init = FALSE;    /* No explicit init, don't let erroneous joins init. */
8743
8744   cbt = ffeglobal_hook (g);
8745
8746   /* If we already have declared this common block for a previous program
8747      unit, and either we already initialized it or we don't have new
8748      initialization for it, just return what we have without changing it.  */
8749
8750   if ((cbt != NULL_TREE)
8751       && (!is_init
8752           || !DECL_EXTERNAL (cbt)))
8753     return;
8754
8755   /* Process inits.  */
8756
8757   if (is_init)
8758     {
8759       if (ffestorag_init (st) != NULL)
8760         {
8761           ffebld sexp;
8762
8763           /* Set the padding for the expression, so ffecom_expr
8764              knows to insert that many zeros.  */
8765           switch (ffebld_op (sexp = ffestorag_init (st)))
8766             {
8767             case FFEBLD_opCONTER:
8768               ffebld_conter_set_pad (sexp, ffestorag_modulo (st));
8769               break;
8770
8771             case FFEBLD_opARRTER:
8772               ffebld_arrter_set_pad (sexp, ffestorag_modulo (st));
8773               break;
8774
8775             case FFEBLD_opACCTER:
8776               ffebld_accter_set_pad (sexp, ffestorag_modulo (st));
8777               break;
8778
8779             default:
8780               assert ("bad op for cmn init (pad)" == NULL);
8781               break;
8782             }
8783
8784           init = ffecom_expr (sexp);
8785           if (init == error_mark_node)
8786             {                   /* Hopefully the back end complained! */
8787               init = NULL_TREE;
8788               if (cbt != NULL_TREE)
8789                 return;
8790             }
8791         }
8792       else
8793         init = error_mark_node;
8794     }
8795   else
8796     init = NULL_TREE;
8797
8798   push_obstacks_nochange ();
8799   end_temporary_allocation ();
8800
8801   /* cbtype must be permanently allocated!  */
8802
8803   /* Allocate the MAX of the areas so far, seen filewide.  */
8804   high = build_int_2 ((ffeglobal_common_size (g)
8805                        + ffeglobal_common_pad (g)) - 1, 0);
8806   TREE_TYPE (high) = ffecom_integer_type_node;
8807
8808   if (init)
8809     cbtype = build_array_type (char_type_node,
8810                                build_range_type (integer_type_node,
8811                                                  integer_zero_node,
8812                                                  high));
8813   else
8814     cbtype = build_array_type (char_type_node, NULL_TREE);
8815
8816   if (cbt == NULL_TREE)
8817     {
8818       cbt
8819         = build_decl (VAR_DECL,
8820                       ffecom_get_external_identifier_ (s),
8821                       cbtype);
8822       TREE_STATIC (cbt) = 1;
8823       TREE_PUBLIC (cbt) = 1;
8824     }
8825   else
8826     {
8827       assert (is_init);
8828       TREE_TYPE (cbt) = cbtype;
8829     }
8830   DECL_EXTERNAL (cbt) = init ? 0 : 1;
8831   DECL_INITIAL (cbt) = init ? error_mark_node : NULL_TREE;
8832
8833   cbt = start_decl (cbt, TRUE);
8834   if (ffeglobal_hook (g) != NULL)
8835     assert (cbt == ffeglobal_hook (g));
8836
8837   assert (!init || !DECL_EXTERNAL (cbt));
8838
8839   /* Make sure that any type can live in COMMON and be referenced
8840      without getting a bus error.  We could pick the most restrictive
8841      alignment of all entities actually placed in the COMMON, but
8842      this seems easy enough.  */
8843
8844   DECL_ALIGN (cbt) = BIGGEST_ALIGNMENT;
8845
8846   if (is_init && (ffestorag_init (st) == NULL))
8847     init = ffecom_init_zero_ (cbt);
8848
8849   finish_decl (cbt, init, TRUE);
8850
8851   if (is_init)
8852     ffestorag_set_init (st, ffebld_new_any ());
8853
8854   if (init)
8855     {
8856       tree size_tree;
8857
8858       assert (DECL_SIZE (cbt) != NULL_TREE);
8859       assert (TREE_CODE (DECL_SIZE (cbt)) == INTEGER_CST);
8860       size_tree = size_binop (CEIL_DIV_EXPR,
8861                               DECL_SIZE (cbt),
8862                               size_int (BITS_PER_UNIT));
8863       assert (TREE_INT_CST_HIGH (size_tree) == 0);
8864       assert (TREE_INT_CST_LOW (size_tree)
8865               == ffeglobal_common_size (g) + ffeglobal_common_pad (g));
8866     }
8867
8868   ffeglobal_set_hook (g, cbt);
8869
8870   ffestorag_set_hook (st, cbt);
8871
8872   resume_temporary_allocation ();
8873   pop_obstacks ();
8874 }
8875
8876 #endif
8877 /* Make master area for local EQUIVALENCE.  */
8878
8879 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8880 static void
8881 ffecom_transform_equiv_ (ffestorag eqst)
8882 {
8883   tree eqt;
8884   tree eqtype;
8885   tree init;
8886   tree high;
8887   bool is_init = ffestorag_is_init (eqst);
8888   int yes;
8889
8890   assert (eqst != NULL);
8891
8892   eqt = ffestorag_hook (eqst);
8893
8894   if (eqt != NULL_TREE)
8895     return;
8896
8897   /* Process inits.  */
8898
8899   if (is_init)
8900     {
8901       if (ffestorag_init (eqst) != NULL)
8902         {
8903           ffebld sexp;
8904
8905           /* Set the padding for the expression, so ffecom_expr
8906              knows to insert that many zeros.  */
8907           switch (ffebld_op (sexp = ffestorag_init (eqst)))
8908             {
8909             case FFEBLD_opCONTER:
8910               ffebld_conter_set_pad (sexp, ffestorag_modulo (eqst));
8911               break;
8912
8913             case FFEBLD_opARRTER:
8914               ffebld_arrter_set_pad (sexp, ffestorag_modulo (eqst));
8915               break;
8916
8917             case FFEBLD_opACCTER:
8918               ffebld_accter_set_pad (sexp, ffestorag_modulo (eqst));
8919               break;
8920
8921             default:
8922               assert ("bad op for eqv init (pad)" == NULL);
8923               break;
8924             }
8925
8926           init = ffecom_expr (sexp);
8927           if (init == error_mark_node)
8928             init = NULL_TREE;   /* Hopefully the back end complained! */
8929         }
8930       else
8931         init = error_mark_node;
8932     }
8933   else if (ffe_is_init_local_zero ())
8934     init = error_mark_node;
8935   else
8936     init = NULL_TREE;
8937
8938   ffecom_member_namelisted_ = FALSE;
8939   ffestorag_drive (ffestorag_list_equivs (eqst),
8940                    &ffecom_member_phase1_,
8941                    eqst);
8942
8943   yes = suspend_momentary ();
8944
8945   high = build_int_2 ((ffestorag_size (eqst)
8946                        + ffestorag_modulo (eqst)) - 1, 0);
8947   TREE_TYPE (high) = ffecom_integer_type_node;
8948
8949   eqtype = build_array_type (char_type_node,
8950                              build_range_type (ffecom_integer_type_node,
8951                                                ffecom_integer_zero_node,
8952                                                high));
8953
8954   eqt = build_decl (VAR_DECL,
8955                     ffecom_get_invented_identifier ("__g77_equiv_%s",
8956                                                     ffesymbol_text
8957                                                     (ffestorag_symbol
8958                                                      (eqst)),
8959                                                     -1),
8960                     eqtype);
8961   DECL_EXTERNAL (eqt) = 0;
8962   if (is_init
8963       || ffecom_member_namelisted_
8964 #ifdef FFECOM_sizeMAXSTACKITEM
8965       || (ffestorag_size (eqst) > FFECOM_sizeMAXSTACKITEM)
8966 #endif
8967       || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8968           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
8969           && (ffestorag_is_save (eqst) || ffe_is_saveall ())))
8970     TREE_STATIC (eqt) = 1;
8971   else
8972     TREE_STATIC (eqt) = 0;
8973   TREE_PUBLIC (eqt) = 0;
8974   DECL_CONTEXT (eqt) = current_function_decl;
8975   if (init)
8976     DECL_INITIAL (eqt) = error_mark_node;
8977   else
8978     DECL_INITIAL (eqt) = NULL_TREE;
8979
8980   eqt = start_decl (eqt, FALSE);
8981
8982   /* Make sure that any type can live in EQUIVALENCE and be referenced
8983      without getting a bus error.  We could pick the most restrictive
8984      alignment of all entities actually placed in the EQUIVALENCE, but
8985      this seems easy enough.  */
8986
8987   DECL_ALIGN (eqt) = BIGGEST_ALIGNMENT;
8988
8989   if ((!is_init && ffe_is_init_local_zero ())
8990       || (is_init && (ffestorag_init (eqst) == NULL)))
8991     init = ffecom_init_zero_ (eqt);
8992
8993   finish_decl (eqt, init, FALSE);
8994
8995   if (is_init)
8996     ffestorag_set_init (eqst, ffebld_new_any ());
8997
8998   {
8999     tree size_tree;
9000
9001     size_tree = size_binop (CEIL_DIV_EXPR,
9002                             DECL_SIZE (eqt),
9003                             size_int (BITS_PER_UNIT));
9004     assert (TREE_INT_CST_HIGH (size_tree) == 0);
9005     assert (TREE_INT_CST_LOW (size_tree)
9006             == ffestorag_size (eqst) + ffestorag_modulo (eqst));
9007   }
9008
9009   ffestorag_set_hook (eqst, eqt);
9010
9011 #ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
9012   ffestorag_drive (ffestorag_list_equivs (eqst),
9013                    &ffecom_member_phase2_,
9014                    eqst);
9015 #endif
9016
9017   resume_momentary (yes);
9018 }
9019
9020 #endif
9021 /* Implement NAMELIST in back end.  See f2c/format.c for more info.  */
9022
9023 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9024 static tree
9025 ffecom_transform_namelist_ (ffesymbol s)
9026 {
9027   tree nmlt;
9028   tree nmltype = ffecom_type_namelist_ ();
9029   tree nmlinits;
9030   tree nameinit;
9031   tree varsinit;
9032   tree nvarsinit;
9033   tree field;
9034   tree high;
9035   int yes;
9036   int i;
9037   static int mynumber = 0;
9038
9039   yes = suspend_momentary ();
9040
9041   nmlt = build_decl (VAR_DECL,
9042                      ffecom_get_invented_identifier ("__g77_namelist_%d",
9043                                                      NULL, mynumber++),
9044                      nmltype);
9045   TREE_STATIC (nmlt) = 1;
9046   DECL_INITIAL (nmlt) = error_mark_node;
9047
9048   nmlt = start_decl (nmlt, FALSE);
9049
9050   /* Process inits.  */
9051
9052   i = strlen (ffesymbol_text (s));
9053
9054   high = build_int_2 (i, 0);
9055   TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
9056
9057   nameinit = ffecom_build_f2c_string_ (i + 1,
9058                                        ffesymbol_text (s));
9059   TREE_TYPE (nameinit)
9060     = build_type_variant
9061     (build_array_type
9062      (char_type_node,
9063       build_range_type (ffecom_f2c_ftnlen_type_node,
9064                         ffecom_f2c_ftnlen_one_node,
9065                         high)),
9066      1, 0);
9067   TREE_CONSTANT (nameinit) = 1;
9068   TREE_STATIC (nameinit) = 1;
9069   nameinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (nameinit)),
9070                        nameinit);
9071
9072   varsinit = ffecom_vardesc_array_ (s);
9073   varsinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (varsinit)),
9074                        varsinit);
9075   TREE_CONSTANT (varsinit) = 1;
9076   TREE_STATIC (varsinit) = 1;
9077
9078   {
9079     ffebld b;
9080
9081     for (i = 0, b = ffesymbol_namelist (s); b != NULL; b = ffebld_trail (b))
9082       ++i;
9083   }
9084   nvarsinit = build_int_2 (i, 0);
9085   TREE_TYPE (nvarsinit) = integer_type_node;
9086   TREE_CONSTANT (nvarsinit) = 1;
9087   TREE_STATIC (nvarsinit) = 1;
9088
9089   nmlinits = build_tree_list ((field = TYPE_FIELDS (nmltype)), nameinit);
9090   TREE_CHAIN (nmlinits) = build_tree_list ((field = TREE_CHAIN (field)),
9091                                            varsinit);
9092   TREE_CHAIN (TREE_CHAIN (nmlinits))
9093     = build_tree_list ((field = TREE_CHAIN (field)), nvarsinit);
9094
9095   nmlinits = build (CONSTRUCTOR, nmltype, NULL_TREE, nmlinits);
9096   TREE_CONSTANT (nmlinits) = 1;
9097   TREE_STATIC (nmlinits) = 1;
9098
9099   finish_decl (nmlt, nmlinits, FALSE);
9100
9101   nmlt = ffecom_1 (ADDR_EXPR, build_pointer_type (nmltype), nmlt);
9102
9103   resume_momentary (yes);
9104
9105   return nmlt;
9106 }
9107
9108 #endif
9109
9110 /* A subroutine of ffecom_tree_canonize_ref_.  The incoming tree is
9111    analyzed on the assumption it is calculating a pointer to be
9112    indirected through.  It must return the proper decl and offset,
9113    taking into account different units of measurements for offsets.  */
9114
9115 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9116 static void
9117 ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
9118                            tree t)
9119 {
9120   switch (TREE_CODE (t))
9121     {
9122     case NOP_EXPR:
9123     case CONVERT_EXPR:
9124     case NON_LVALUE_EXPR:
9125       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
9126       break;
9127
9128     case PLUS_EXPR:
9129       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
9130       if ((*decl == NULL_TREE)
9131           || (*decl == error_mark_node))
9132         break;
9133
9134       if (TREE_CODE (TREE_OPERAND (t, 1)) == INTEGER_CST)
9135         {
9136           /* An offset into COMMON.  */
9137           *offset = size_binop (PLUS_EXPR,
9138                                 *offset,
9139                                 TREE_OPERAND (t, 1));
9140           /* Convert offset (presumably in bytes) into canonical units
9141              (presumably bits).  */
9142           *offset = size_binop (MULT_EXPR,
9143                                 TYPE_SIZE (TREE_TYPE (TREE_TYPE (t))),
9144                                 *offset);
9145           break;
9146         }
9147       /* Not a COMMON reference, so an unrecognized pattern.  */
9148       *decl = error_mark_node;
9149       break;
9150
9151     case PARM_DECL:
9152       *decl = t;
9153       *offset = bitsize_int (0L, 0L);
9154       break;
9155
9156     case ADDR_EXPR:
9157       if (TREE_CODE (TREE_OPERAND (t, 0)) == VAR_DECL)
9158         {
9159           /* A reference to COMMON.  */
9160           *decl = TREE_OPERAND (t, 0);
9161           *offset = bitsize_int (0L, 0L);
9162           break;
9163         }
9164       /* Fall through.  */
9165     default:
9166       /* Not a COMMON reference, so an unrecognized pattern.  */
9167       *decl = error_mark_node;
9168       break;
9169     }
9170 }
9171 #endif
9172
9173 /* Given a tree that is possibly intended for use as an lvalue, return
9174    information representing a canonical view of that tree as a decl, an
9175    offset into that decl, and a size for the lvalue.
9176
9177    If there's no applicable decl, NULL_TREE is returned for the decl,
9178    and the other fields are left undefined.
9179
9180    If the tree doesn't fit the recognizable forms, an ERROR_MARK node
9181    is returned for the decl, and the other fields are left undefined.
9182
9183    Otherwise, the decl returned currently is either a VAR_DECL or a
9184    PARM_DECL.
9185
9186    The offset returned is always valid, but of course not necessarily
9187    a constant, and not necessarily converted into the appropriate
9188    type, leaving that up to the caller (so as to avoid that overhead
9189    if the decls being looked at are different anyway).
9190
9191    If the size cannot be determined (e.g. an adjustable array),
9192    an ERROR_MARK node is returned for the size.  Otherwise, the
9193    size returned is valid, not necessarily a constant, and not
9194    necessarily converted into the appropriate type as with the
9195    offset.
9196
9197    Note that the offset and size expressions are expressed in the
9198    base storage units (usually bits) rather than in the units of
9199    the type of the decl, because two decls with different types
9200    might overlap but with apparently non-overlapping array offsets,
9201    whereas converting the array offsets to consistant offsets will
9202    reveal the overlap.  */
9203
9204 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9205 static void
9206 ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
9207                            tree *size, tree t)
9208 {
9209   /* The default path is to report a nonexistant decl.  */
9210   *decl = NULL_TREE;
9211
9212   if (t == NULL_TREE)
9213     return;
9214
9215   switch (TREE_CODE (t))
9216     {
9217     case ERROR_MARK:
9218     case IDENTIFIER_NODE:
9219     case INTEGER_CST:
9220     case REAL_CST:
9221     case COMPLEX_CST:
9222     case STRING_CST:
9223     case CONST_DECL:
9224     case PLUS_EXPR:
9225     case MINUS_EXPR:
9226     case MULT_EXPR:
9227     case TRUNC_DIV_EXPR:
9228     case CEIL_DIV_EXPR:
9229     case FLOOR_DIV_EXPR:
9230     case ROUND_DIV_EXPR:
9231     case TRUNC_MOD_EXPR:
9232     case CEIL_MOD_EXPR:
9233     case FLOOR_MOD_EXPR:
9234     case ROUND_MOD_EXPR:
9235     case RDIV_EXPR:
9236     case EXACT_DIV_EXPR:
9237     case FIX_TRUNC_EXPR:
9238     case FIX_CEIL_EXPR:
9239     case FIX_FLOOR_EXPR:
9240     case FIX_ROUND_EXPR:
9241     case FLOAT_EXPR:
9242     case EXPON_EXPR:
9243     case NEGATE_EXPR:
9244     case MIN_EXPR:
9245     case MAX_EXPR:
9246     case ABS_EXPR:
9247     case FFS_EXPR:
9248     case LSHIFT_EXPR:
9249     case RSHIFT_EXPR:
9250     case LROTATE_EXPR:
9251     case RROTATE_EXPR:
9252     case BIT_IOR_EXPR:
9253     case BIT_XOR_EXPR:
9254     case BIT_AND_EXPR:
9255     case BIT_ANDTC_EXPR:
9256     case BIT_NOT_EXPR:
9257     case TRUTH_ANDIF_EXPR:
9258     case TRUTH_ORIF_EXPR:
9259     case TRUTH_AND_EXPR:
9260     case TRUTH_OR_EXPR:
9261     case TRUTH_XOR_EXPR:
9262     case TRUTH_NOT_EXPR:
9263     case LT_EXPR:
9264     case LE_EXPR:
9265     case GT_EXPR:
9266     case GE_EXPR:
9267     case EQ_EXPR:
9268     case NE_EXPR:
9269     case COMPLEX_EXPR:
9270     case CONJ_EXPR:
9271     case REALPART_EXPR:
9272     case IMAGPART_EXPR:
9273     case LABEL_EXPR:
9274     case COMPONENT_REF:
9275     case COMPOUND_EXPR:
9276     case ADDR_EXPR:
9277       return;
9278
9279     case VAR_DECL:
9280     case PARM_DECL:
9281       *decl = t;
9282       *offset = bitsize_int (0L, 0L);
9283       *size = TYPE_SIZE (TREE_TYPE (t));
9284       return;
9285
9286     case ARRAY_REF:
9287       {
9288         tree array = TREE_OPERAND (t, 0);
9289         tree element = TREE_OPERAND (t, 1);
9290         tree init_offset;
9291
9292         if ((array == NULL_TREE)
9293             || (element == NULL_TREE))
9294           {
9295             *decl = error_mark_node;
9296             return;
9297           }
9298
9299         ffecom_tree_canonize_ref_ (decl, &init_offset, size,
9300                                    array);
9301         if ((*decl == NULL_TREE)
9302             || (*decl == error_mark_node))
9303           return;
9304
9305         *offset = size_binop (MULT_EXPR,
9306                               TYPE_SIZE (TREE_TYPE (TREE_TYPE (array))),
9307                               size_binop (MINUS_EXPR,
9308                                           element,
9309                                           TYPE_MIN_VALUE
9310                                           (TYPE_DOMAIN
9311                                            (TREE_TYPE (array)))));
9312
9313         *offset = size_binop (PLUS_EXPR,
9314                               init_offset,
9315                               *offset);
9316
9317         *size = TYPE_SIZE (TREE_TYPE (t));
9318         return;
9319       }
9320
9321     case INDIRECT_REF:
9322
9323       /* Most of this code is to handle references to COMMON.  And so
9324          far that is useful only for calling library functions, since
9325          external (user) functions might reference common areas.  But
9326          even calling an external function, it's worthwhile to decode
9327          COMMON references because if not storing into COMMON, we don't
9328          want COMMON-based arguments to gratuitously force use of a
9329          temporary.  */
9330
9331       *size = TYPE_SIZE (TREE_TYPE (t));
9332
9333       ffecom_tree_canonize_ptr_ (decl, offset,
9334                                  TREE_OPERAND (t, 0));
9335
9336       return;
9337
9338     case CONVERT_EXPR:
9339     case NOP_EXPR:
9340     case MODIFY_EXPR:
9341     case NON_LVALUE_EXPR:
9342     case RESULT_DECL:
9343     case FIELD_DECL:
9344     case COND_EXPR:             /* More cases than we can handle. */
9345     case SAVE_EXPR:
9346     case REFERENCE_EXPR:
9347     case PREDECREMENT_EXPR:
9348     case PREINCREMENT_EXPR:
9349     case POSTDECREMENT_EXPR:
9350     case POSTINCREMENT_EXPR:
9351     case CALL_EXPR:
9352     default:
9353       *decl = error_mark_node;
9354       return;
9355     }
9356 }
9357 #endif
9358
9359 /* Do divide operation appropriate to type of operands.  */
9360
9361 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9362 static tree
9363 ffecom_tree_divide_ (tree tree_type, tree left, tree right,
9364                      tree dest_tree, ffebld dest, bool *dest_used,
9365                      tree hook)
9366 {
9367   if ((left == error_mark_node)
9368       || (right == error_mark_node))
9369     return error_mark_node;
9370
9371   switch (TREE_CODE (tree_type))
9372     {
9373     case INTEGER_TYPE:
9374       return ffecom_2 (TRUNC_DIV_EXPR, tree_type,
9375                        left,
9376                        right);
9377
9378     case COMPLEX_TYPE:
9379       if (! optimize_size)
9380         return ffecom_2 (RDIV_EXPR, tree_type,
9381                          left,
9382                          right);
9383       {
9384         ffecomGfrt ix;
9385
9386         if (TREE_TYPE (tree_type)
9387             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9388           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9389         else
9390           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9391
9392         left = ffecom_1 (ADDR_EXPR,
9393                          build_pointer_type (TREE_TYPE (left)),
9394                          left);
9395         left = build_tree_list (NULL_TREE, left);
9396         right = ffecom_1 (ADDR_EXPR,
9397                           build_pointer_type (TREE_TYPE (right)),
9398                           right);
9399         right = build_tree_list (NULL_TREE, right);
9400         TREE_CHAIN (left) = right;
9401
9402         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9403                              ffecom_gfrt_kindtype (ix),
9404                              ffe_is_f2c_library (),
9405                              tree_type,
9406                              left,
9407                              dest_tree, dest, dest_used,
9408                              NULL_TREE, TRUE, hook);
9409       }
9410       break;
9411
9412     case RECORD_TYPE:
9413       {
9414         ffecomGfrt ix;
9415
9416         if (TREE_TYPE (TYPE_FIELDS (tree_type))
9417             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9418           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9419         else
9420           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9421
9422         left = ffecom_1 (ADDR_EXPR,
9423                          build_pointer_type (TREE_TYPE (left)),
9424                          left);
9425         left = build_tree_list (NULL_TREE, left);
9426         right = ffecom_1 (ADDR_EXPR,
9427                           build_pointer_type (TREE_TYPE (right)),
9428                           right);
9429         right = build_tree_list (NULL_TREE, right);
9430         TREE_CHAIN (left) = right;
9431
9432         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9433                              ffecom_gfrt_kindtype (ix),
9434                              ffe_is_f2c_library (),
9435                              tree_type,
9436                              left,
9437                              dest_tree, dest, dest_used,
9438                              NULL_TREE, TRUE, hook);
9439       }
9440       break;
9441
9442     default:
9443       return ffecom_2 (RDIV_EXPR, tree_type,
9444                        left,
9445                        right);
9446     }
9447 }
9448
9449 #endif
9450 /* Build type info for non-dummy variable.  */
9451
9452 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9453 static tree
9454 ffecom_type_localvar_ (ffesymbol s, ffeinfoBasictype bt,
9455                        ffeinfoKindtype kt)
9456 {
9457   tree type;
9458   ffebld dl;
9459   ffebld dim;
9460   tree lowt;
9461   tree hight;
9462
9463   type = ffecom_tree_type[bt][kt];
9464   if (bt == FFEINFO_basictypeCHARACTER)
9465     {
9466       hight = build_int_2 (ffesymbol_size (s), 0);
9467       TREE_TYPE (hight) = ffecom_f2c_ftnlen_type_node;
9468
9469       type
9470         = build_array_type
9471           (type,
9472            build_range_type (ffecom_f2c_ftnlen_type_node,
9473                              ffecom_f2c_ftnlen_one_node,
9474                              hight));
9475       type = ffecom_check_size_overflow_ (s, type, FALSE);
9476     }
9477
9478   for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
9479     {
9480       if (type == error_mark_node)
9481         break;
9482
9483       dim = ffebld_head (dl);
9484       assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
9485
9486       if (ffebld_left (dim) == NULL)
9487         lowt = integer_one_node;
9488       else
9489         lowt = ffecom_expr (ffebld_left (dim));
9490
9491       if (TREE_CODE (lowt) != INTEGER_CST)
9492         lowt = variable_size (lowt);
9493
9494       assert (ffebld_right (dim) != NULL);
9495       hight = ffecom_expr (ffebld_right (dim));
9496
9497       if (TREE_CODE (hight) != INTEGER_CST)
9498         hight = variable_size (hight);
9499
9500       type = build_array_type (type,
9501                                build_range_type (ffecom_integer_type_node,
9502                                                  lowt, hight));
9503       type = ffecom_check_size_overflow_ (s, type, FALSE);
9504     }
9505
9506   return type;
9507 }
9508
9509 #endif
9510 /* Build Namelist type.  */
9511
9512 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9513 static tree
9514 ffecom_type_namelist_ ()
9515 {
9516   static tree type = NULL_TREE;
9517
9518   if (type == NULL_TREE)
9519     {
9520       static tree namefield, varsfield, nvarsfield;
9521       tree vardesctype;
9522
9523       vardesctype = ffecom_type_vardesc_ ();
9524
9525       push_obstacks_nochange ();
9526       end_temporary_allocation ();
9527
9528       type = make_node (RECORD_TYPE);
9529
9530       vardesctype = build_pointer_type (build_pointer_type (vardesctype));
9531
9532       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9533                                      string_type_node);
9534       varsfield = ffecom_decl_field (type, namefield, "vars", vardesctype);
9535       nvarsfield = ffecom_decl_field (type, varsfield, "nvars",
9536                                       integer_type_node);
9537
9538       TYPE_FIELDS (type) = namefield;
9539       layout_type (type);
9540
9541       resume_temporary_allocation ();
9542       pop_obstacks ();
9543     }
9544
9545   return type;
9546 }
9547
9548 #endif
9549
9550 /* Make a copy of a type, assuming caller has switched to the permanent
9551    obstacks and that the type is for an aggregate (array) initializer.  */
9552
9553 #if FFECOM_targetCURRENT == FFECOM_targetGCC && 0       /* Not used now. */
9554 static tree
9555 ffecom_type_permanent_copy_ (tree t)
9556 {
9557   tree domain;
9558   tree max;
9559
9560   assert (TREE_TYPE (t) != NULL_TREE);
9561
9562   domain = TYPE_DOMAIN (t);
9563
9564   assert (TREE_CODE (t) == ARRAY_TYPE);
9565   assert (TREE_PERMANENT (TREE_TYPE (t)));
9566   assert (TREE_PERMANENT (TREE_TYPE (domain)));
9567   assert (TREE_PERMANENT (TYPE_MIN_VALUE (domain)));
9568
9569   max = TYPE_MAX_VALUE (domain);
9570   if (!TREE_PERMANENT (max))
9571     {
9572       assert (TREE_CODE (max) == INTEGER_CST);
9573
9574       max = build_int_2 (TREE_INT_CST_LOW (max), TREE_INT_CST_HIGH (max));
9575       TREE_TYPE (max) = TREE_TYPE (TYPE_MIN_VALUE (domain));
9576     }
9577
9578   return build_array_type (TREE_TYPE (t),
9579                            build_range_type (TREE_TYPE (domain),
9580                                              TYPE_MIN_VALUE (domain),
9581                                              max));
9582 }
9583 #endif
9584
9585 /* Build Vardesc type.  */
9586
9587 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9588 static tree
9589 ffecom_type_vardesc_ ()
9590 {
9591   static tree type = NULL_TREE;
9592   static tree namefield, addrfield, dimsfield, typefield;
9593
9594   if (type == NULL_TREE)
9595     {
9596       push_obstacks_nochange ();
9597       end_temporary_allocation ();
9598
9599       type = make_node (RECORD_TYPE);
9600
9601       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9602                                      string_type_node);
9603       addrfield = ffecom_decl_field (type, namefield, "addr",
9604                                      string_type_node);
9605       dimsfield = ffecom_decl_field (type, addrfield, "dims",
9606                                      ffecom_f2c_ptr_to_ftnlen_type_node);
9607       typefield = ffecom_decl_field (type, dimsfield, "type",
9608                                      integer_type_node);
9609
9610       TYPE_FIELDS (type) = namefield;
9611       layout_type (type);
9612
9613       resume_temporary_allocation ();
9614       pop_obstacks ();
9615     }
9616
9617   return type;
9618 }
9619
9620 #endif
9621
9622 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9623 static tree
9624 ffecom_vardesc_ (ffebld expr)
9625 {
9626   ffesymbol s;
9627
9628   assert (ffebld_op (expr) == FFEBLD_opSYMTER);
9629   s = ffebld_symter (expr);
9630
9631   if (ffesymbol_hook (s).vardesc_tree == NULL_TREE)
9632     {
9633       int i;
9634       tree vardesctype = ffecom_type_vardesc_ ();
9635       tree var;
9636       tree nameinit;
9637       tree dimsinit;
9638       tree addrinit;
9639       tree typeinit;
9640       tree field;
9641       tree varinits;
9642       int yes;
9643       static int mynumber = 0;
9644
9645       yes = suspend_momentary ();
9646
9647       var = build_decl (VAR_DECL,
9648                         ffecom_get_invented_identifier ("__g77_vardesc_%d",
9649                                                         NULL, mynumber++),
9650                         vardesctype);
9651       TREE_STATIC (var) = 1;
9652       DECL_INITIAL (var) = error_mark_node;
9653
9654       var = start_decl (var, FALSE);
9655
9656       /* Process inits.  */
9657
9658       nameinit = ffecom_build_f2c_string_ ((i = strlen (ffesymbol_text (s)))
9659                                            + 1,
9660                                            ffesymbol_text (s));
9661       TREE_TYPE (nameinit)
9662         = build_type_variant
9663         (build_array_type
9664          (char_type_node,
9665           build_range_type (integer_type_node,
9666                             integer_one_node,
9667                             build_int_2 (i, 0))),
9668          1, 0);
9669       TREE_CONSTANT (nameinit) = 1;
9670       TREE_STATIC (nameinit) = 1;
9671       nameinit = ffecom_1 (ADDR_EXPR,
9672                            build_pointer_type (TREE_TYPE (nameinit)),
9673                            nameinit);
9674
9675       addrinit = ffecom_arg_ptr_to_expr (expr, &typeinit);
9676
9677       dimsinit = ffecom_vardesc_dims_ (s);
9678
9679       if (typeinit == NULL_TREE)
9680         {
9681           ffeinfoBasictype bt = ffesymbol_basictype (s);
9682           ffeinfoKindtype kt = ffesymbol_kindtype (s);
9683           int tc = ffecom_f2c_typecode (bt, kt);
9684
9685           assert (tc != -1);
9686           typeinit = build_int_2 (tc, (tc < 0) ? -1 : 0);
9687         }
9688       else
9689         typeinit = ffecom_1 (NEGATE_EXPR, TREE_TYPE (typeinit), typeinit);
9690
9691       varinits = build_tree_list ((field = TYPE_FIELDS (vardesctype)),
9692                                   nameinit);
9693       TREE_CHAIN (varinits) = build_tree_list ((field = TREE_CHAIN (field)),
9694                                                addrinit);
9695       TREE_CHAIN (TREE_CHAIN (varinits))
9696         = build_tree_list ((field = TREE_CHAIN (field)), dimsinit);
9697       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits)))
9698         = build_tree_list ((field = TREE_CHAIN (field)), typeinit);
9699
9700       varinits = build (CONSTRUCTOR, vardesctype, NULL_TREE, varinits);
9701       TREE_CONSTANT (varinits) = 1;
9702       TREE_STATIC (varinits) = 1;
9703
9704       finish_decl (var, varinits, FALSE);
9705
9706       var = ffecom_1 (ADDR_EXPR, build_pointer_type (vardesctype), var);
9707
9708       resume_momentary (yes);
9709
9710       ffesymbol_hook (s).vardesc_tree = var;
9711     }
9712
9713   return ffesymbol_hook (s).vardesc_tree;
9714 }
9715
9716 #endif
9717 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9718 static tree
9719 ffecom_vardesc_array_ (ffesymbol s)
9720 {
9721   ffebld b;
9722   tree list;
9723   tree item = NULL_TREE;
9724   tree var;
9725   int i;
9726   int yes;
9727   static int mynumber = 0;
9728
9729   for (i = 0, list = NULL_TREE, b = ffesymbol_namelist (s);
9730        b != NULL;
9731        b = ffebld_trail (b), ++i)
9732     {
9733       tree t;
9734
9735       t = ffecom_vardesc_ (ffebld_head (b));
9736
9737       if (list == NULL_TREE)
9738         list = item = build_tree_list (NULL_TREE, t);
9739       else
9740         {
9741           TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9742           item = TREE_CHAIN (item);
9743         }
9744     }
9745
9746   yes = suspend_momentary ();
9747
9748   item = build_array_type (build_pointer_type (ffecom_type_vardesc_ ()),
9749                            build_range_type (integer_type_node,
9750                                              integer_one_node,
9751                                              build_int_2 (i, 0)));
9752   list = build (CONSTRUCTOR, item, NULL_TREE, list);
9753   TREE_CONSTANT (list) = 1;
9754   TREE_STATIC (list) = 1;
9755
9756   var = ffecom_get_invented_identifier ("__g77_vardesc_array_%d", NULL,
9757                                         mynumber++);
9758   var = build_decl (VAR_DECL, var, item);
9759   TREE_STATIC (var) = 1;
9760   DECL_INITIAL (var) = error_mark_node;
9761   var = start_decl (var, FALSE);
9762   finish_decl (var, list, FALSE);
9763
9764   resume_momentary (yes);
9765
9766   return var;
9767 }
9768
9769 #endif
9770 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9771 static tree
9772 ffecom_vardesc_dims_ (ffesymbol s)
9773 {
9774   if (ffesymbol_dims (s) == NULL)
9775     return convert (ffecom_f2c_ptr_to_ftnlen_type_node,
9776                     integer_zero_node);
9777
9778   {
9779     ffebld b;
9780     ffebld e;
9781     tree list;
9782     tree backlist;
9783     tree item = NULL_TREE;
9784     tree var;
9785     int yes;
9786     tree numdim;
9787     tree numelem;
9788     tree baseoff = NULL_TREE;
9789     static int mynumber = 0;
9790
9791     numdim = build_int_2 ((int) ffesymbol_rank (s), 0);
9792     TREE_TYPE (numdim) = ffecom_f2c_ftnlen_type_node;
9793
9794     numelem = ffecom_expr (ffesymbol_arraysize (s));
9795     TREE_TYPE (numelem) = ffecom_f2c_ftnlen_type_node;
9796
9797     list = NULL_TREE;
9798     backlist = NULL_TREE;
9799     for (b = ffesymbol_dims (s), e = ffesymbol_extents (s);
9800          b != NULL;
9801          b = ffebld_trail (b), e = ffebld_trail (e))
9802       {
9803         tree t;
9804         tree low;
9805         tree back;
9806
9807         if (ffebld_trail (b) == NULL)
9808           t = NULL_TREE;
9809         else
9810           {
9811             t = convert (ffecom_f2c_ftnlen_type_node,
9812                          ffecom_expr (ffebld_head (e)));
9813
9814             if (list == NULL_TREE)
9815               list = item = build_tree_list (NULL_TREE, t);
9816             else
9817               {
9818                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9819                 item = TREE_CHAIN (item);
9820               }
9821           }
9822
9823         if (ffebld_left (ffebld_head (b)) == NULL)
9824           low = ffecom_integer_one_node;
9825         else
9826           low = ffecom_expr (ffebld_left (ffebld_head (b)));
9827         low = convert (ffecom_f2c_ftnlen_type_node, low);
9828
9829         back = build_tree_list (low, t);
9830         TREE_CHAIN (back) = backlist;
9831         backlist = back;
9832       }
9833
9834     for (item = backlist; item != NULL_TREE; item = TREE_CHAIN (item))
9835       {
9836         if (TREE_VALUE (item) == NULL_TREE)
9837           baseoff = TREE_PURPOSE (item);
9838         else
9839           baseoff = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
9840                               TREE_PURPOSE (item),
9841                               ffecom_2 (MULT_EXPR,
9842                                         ffecom_f2c_ftnlen_type_node,
9843                                         TREE_VALUE (item),
9844                                         baseoff));
9845       }
9846
9847     /* backlist now dead, along with all TREE_PURPOSEs on it.  */
9848
9849     baseoff = build_tree_list (NULL_TREE, baseoff);
9850     TREE_CHAIN (baseoff) = list;
9851
9852     numelem = build_tree_list (NULL_TREE, numelem);
9853     TREE_CHAIN (numelem) = baseoff;
9854
9855     numdim = build_tree_list (NULL_TREE, numdim);
9856     TREE_CHAIN (numdim) = numelem;
9857
9858     yes = suspend_momentary ();
9859
9860     item = build_array_type (ffecom_f2c_ftnlen_type_node,
9861                              build_range_type (integer_type_node,
9862                                                integer_zero_node,
9863                                                build_int_2
9864                                                ((int) ffesymbol_rank (s)
9865                                                 + 2, 0)));
9866     list = build (CONSTRUCTOR, item, NULL_TREE, numdim);
9867     TREE_CONSTANT (list) = 1;
9868     TREE_STATIC (list) = 1;
9869
9870     var = ffecom_get_invented_identifier ("__g77_dims_%d", NULL,
9871                                           mynumber++);
9872     var = build_decl (VAR_DECL, var, item);
9873     TREE_STATIC (var) = 1;
9874     DECL_INITIAL (var) = error_mark_node;
9875     var = start_decl (var, FALSE);
9876     finish_decl (var, list, FALSE);
9877
9878     var = ffecom_1 (ADDR_EXPR, build_pointer_type (item), var);
9879
9880     resume_momentary (yes);
9881
9882     return var;
9883   }
9884 }
9885
9886 #endif
9887 /* Essentially does a "fold (build1 (code, type, node))" while checking
9888    for certain housekeeping things.
9889
9890    NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
9891    ffecom_1_fn instead.  */
9892
9893 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9894 tree
9895 ffecom_1 (enum tree_code code, tree type, tree node)
9896 {
9897   tree item;
9898
9899   if ((node == error_mark_node)
9900       || (type == error_mark_node))
9901     return error_mark_node;
9902
9903   if (code == ADDR_EXPR)
9904     {
9905       if (!mark_addressable (node))
9906         assert ("can't mark_addressable this node!" == NULL);
9907     }
9908
9909   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9910     {
9911       tree realtype;
9912
9913     case REALPART_EXPR:
9914       item = build (COMPONENT_REF, type, node, TYPE_FIELDS (TREE_TYPE (node)));
9915       break;
9916
9917     case IMAGPART_EXPR:
9918       item = build (COMPONENT_REF, type, node, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node))));
9919       break;
9920
9921
9922     case NEGATE_EXPR:
9923       if (TREE_CODE (type) != RECORD_TYPE)
9924         {
9925           item = build1 (code, type, node);
9926           break;
9927         }
9928       node = ffecom_stabilize_aggregate_ (node);
9929       realtype = TREE_TYPE (TYPE_FIELDS (type));
9930       item =
9931         ffecom_2 (COMPLEX_EXPR, type,
9932                   ffecom_1 (NEGATE_EXPR, realtype,
9933                             ffecom_1 (REALPART_EXPR, realtype,
9934                                       node)),
9935                   ffecom_1 (NEGATE_EXPR, realtype,
9936                             ffecom_1 (IMAGPART_EXPR, realtype,
9937                                       node)));
9938       break;
9939
9940     default:
9941       item = build1 (code, type, node);
9942       break;
9943     }
9944
9945   if (TREE_SIDE_EFFECTS (node))
9946     TREE_SIDE_EFFECTS (item) = 1;
9947   if ((code == ADDR_EXPR) && staticp (node))
9948     TREE_CONSTANT (item) = 1;
9949   return fold (item);
9950 }
9951 #endif
9952
9953 /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
9954    handles TREE_CODE (node) == FUNCTION_DECL.  In particular,
9955    does not set TREE_ADDRESSABLE (because calling an inline
9956    function does not mean the function needs to be separately
9957    compiled).  */
9958
9959 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9960 tree
9961 ffecom_1_fn (tree node)
9962 {
9963   tree item;
9964   tree type;
9965
9966   if (node == error_mark_node)
9967     return error_mark_node;
9968
9969   type = build_type_variant (TREE_TYPE (node),
9970                              TREE_READONLY (node),
9971                              TREE_THIS_VOLATILE (node));
9972   item = build1 (ADDR_EXPR,
9973                  build_pointer_type (type), node);
9974   if (TREE_SIDE_EFFECTS (node))
9975     TREE_SIDE_EFFECTS (item) = 1;
9976   if (staticp (node))
9977     TREE_CONSTANT (item) = 1;
9978   return fold (item);
9979 }
9980 #endif
9981
9982 /* Essentially does a "fold (build (code, type, node1, node2))" while
9983    checking for certain housekeeping things.  */
9984
9985 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9986 tree
9987 ffecom_2 (enum tree_code code, tree type, tree node1,
9988           tree node2)
9989 {
9990   tree item;
9991
9992   if ((node1 == error_mark_node)
9993       || (node2 == error_mark_node)
9994       || (type == error_mark_node))
9995     return error_mark_node;
9996
9997   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9998     {
9999       tree a, b, c, d, realtype;
10000
10001     case CONJ_EXPR:
10002       assert ("no CONJ_EXPR support yet" == NULL);
10003       return error_mark_node;
10004
10005     case COMPLEX_EXPR:
10006       item = build_tree_list (TYPE_FIELDS (type), node1);
10007       TREE_CHAIN (item) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), node2);
10008       item = build (CONSTRUCTOR, type, NULL_TREE, item);
10009       break;
10010
10011     case PLUS_EXPR:
10012       if (TREE_CODE (type) != RECORD_TYPE)
10013         {
10014           item = build (code, type, node1, node2);
10015           break;
10016         }
10017       node1 = ffecom_stabilize_aggregate_ (node1);
10018       node2 = ffecom_stabilize_aggregate_ (node2);
10019       realtype = TREE_TYPE (TYPE_FIELDS (type));
10020       item =
10021         ffecom_2 (COMPLEX_EXPR, type,
10022                   ffecom_2 (PLUS_EXPR, realtype,
10023                             ffecom_1 (REALPART_EXPR, realtype,
10024                                       node1),
10025                             ffecom_1 (REALPART_EXPR, realtype,
10026                                       node2)),
10027                   ffecom_2 (PLUS_EXPR, realtype,
10028                             ffecom_1 (IMAGPART_EXPR, realtype,
10029                                       node1),
10030                             ffecom_1 (IMAGPART_EXPR, realtype,
10031                                       node2)));
10032       break;
10033
10034     case MINUS_EXPR:
10035       if (TREE_CODE (type) != RECORD_TYPE)
10036         {
10037           item = build (code, type, node1, node2);
10038           break;
10039         }
10040       node1 = ffecom_stabilize_aggregate_ (node1);
10041       node2 = ffecom_stabilize_aggregate_ (node2);
10042       realtype = TREE_TYPE (TYPE_FIELDS (type));
10043       item =
10044         ffecom_2 (COMPLEX_EXPR, type,
10045                   ffecom_2 (MINUS_EXPR, realtype,
10046                             ffecom_1 (REALPART_EXPR, realtype,
10047                                       node1),
10048                             ffecom_1 (REALPART_EXPR, realtype,
10049                                       node2)),
10050                   ffecom_2 (MINUS_EXPR, realtype,
10051                             ffecom_1 (IMAGPART_EXPR, realtype,
10052                                       node1),
10053                             ffecom_1 (IMAGPART_EXPR, realtype,
10054                                       node2)));
10055       break;
10056
10057     case MULT_EXPR:
10058       if (TREE_CODE (type) != RECORD_TYPE)
10059         {
10060           item = build (code, type, node1, node2);
10061           break;
10062         }
10063       node1 = ffecom_stabilize_aggregate_ (node1);
10064       node2 = ffecom_stabilize_aggregate_ (node2);
10065       realtype = TREE_TYPE (TYPE_FIELDS (type));
10066       a = save_expr (ffecom_1 (REALPART_EXPR, realtype,
10067                                node1));
10068       b = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
10069                                node1));
10070       c = save_expr (ffecom_1 (REALPART_EXPR, realtype,
10071                                node2));
10072       d = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
10073                                node2));
10074       item =
10075         ffecom_2 (COMPLEX_EXPR, type,
10076                   ffecom_2 (MINUS_EXPR, realtype,
10077                             ffecom_2 (MULT_EXPR, realtype,
10078                                       a,
10079                                       c),
10080                             ffecom_2 (MULT_EXPR, realtype,
10081                                       b,
10082                                       d)),
10083                   ffecom_2 (PLUS_EXPR, realtype,
10084                             ffecom_2 (MULT_EXPR, realtype,
10085                                       a,
10086                                       d),
10087                             ffecom_2 (MULT_EXPR, realtype,
10088                                       c,
10089                                       b)));
10090       break;
10091
10092     case EQ_EXPR:
10093       if ((TREE_CODE (node1) != RECORD_TYPE)
10094           && (TREE_CODE (node2) != RECORD_TYPE))
10095         {
10096           item = build (code, type, node1, node2);
10097           break;
10098         }
10099       assert (TREE_CODE (node1) == RECORD_TYPE);
10100       assert (TREE_CODE (node2) == RECORD_TYPE);
10101       node1 = ffecom_stabilize_aggregate_ (node1);
10102       node2 = ffecom_stabilize_aggregate_ (node2);
10103       realtype = TREE_TYPE (TYPE_FIELDS (type));
10104       item =
10105         ffecom_2 (TRUTH_ANDIF_EXPR, type,
10106                   ffecom_2 (code, type,
10107                             ffecom_1 (REALPART_EXPR, realtype,
10108                                       node1),
10109                             ffecom_1 (REALPART_EXPR, realtype,
10110                                       node2)),
10111                   ffecom_2 (code, type,
10112                             ffecom_1 (IMAGPART_EXPR, realtype,
10113                                       node1),
10114                             ffecom_1 (IMAGPART_EXPR, realtype,
10115                                       node2)));
10116       break;
10117
10118     case NE_EXPR:
10119       if ((TREE_CODE (node1) != RECORD_TYPE)
10120           && (TREE_CODE (node2) != RECORD_TYPE))
10121         {
10122           item = build (code, type, node1, node2);
10123           break;
10124         }
10125       assert (TREE_CODE (node1) == RECORD_TYPE);
10126       assert (TREE_CODE (node2) == RECORD_TYPE);
10127       node1 = ffecom_stabilize_aggregate_ (node1);
10128       node2 = ffecom_stabilize_aggregate_ (node2);
10129       realtype = TREE_TYPE (TYPE_FIELDS (type));
10130       item =
10131         ffecom_2 (TRUTH_ORIF_EXPR, type,
10132                   ffecom_2 (code, type,
10133                             ffecom_1 (REALPART_EXPR, realtype,
10134                                       node1),
10135                             ffecom_1 (REALPART_EXPR, realtype,
10136                                       node2)),
10137                   ffecom_2 (code, type,
10138                             ffecom_1 (IMAGPART_EXPR, realtype,
10139                                       node1),
10140                             ffecom_1 (IMAGPART_EXPR, realtype,
10141                                       node2)));
10142       break;
10143
10144     default:
10145       item = build (code, type, node1, node2);
10146       break;
10147     }
10148
10149   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2))
10150     TREE_SIDE_EFFECTS (item) = 1;
10151   return fold (item);
10152 }
10153
10154 #endif
10155 /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
10156
10157    ffesymbol s;  // the ENTRY point itself
10158    if (ffecom_2pass_advise_entrypoint(s))
10159        // the ENTRY point has been accepted
10160
10161    Does whatever compiler needs to do when it learns about the entrypoint,
10162    like determine the return type of the master function, count the
10163    number of entrypoints, etc.  Returns FALSE if the return type is
10164    not compatible with the return type(s) of other entrypoint(s).
10165
10166    NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
10167    later (after _finish_progunit) be called with the same entrypoint(s)
10168    as passed to this fn for which TRUE was returned.
10169
10170    03-Jan-92  JCB  2.0
10171       Return FALSE if the return type conflicts with previous entrypoints.  */
10172
10173 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10174 bool
10175 ffecom_2pass_advise_entrypoint (ffesymbol entry)
10176 {
10177   ffebld list;                  /* opITEM. */
10178   ffebld mlist;                 /* opITEM. */
10179   ffebld plist;                 /* opITEM. */
10180   ffebld arg;                   /* ffebld_head(opITEM). */
10181   ffebld item;                  /* opITEM. */
10182   ffesymbol s;                  /* ffebld_symter(arg). */
10183   ffeinfoBasictype bt = ffesymbol_basictype (entry);
10184   ffeinfoKindtype kt = ffesymbol_kindtype (entry);
10185   ffetargetCharacterSize size = ffesymbol_size (entry);
10186   bool ok;
10187
10188   if (ffecom_num_entrypoints_ == 0)
10189     {                           /* First entrypoint, make list of main
10190                                    arglist's dummies. */
10191       assert (ffecom_primary_entry_ != NULL);
10192
10193       ffecom_master_bt_ = ffesymbol_basictype (ffecom_primary_entry_);
10194       ffecom_master_kt_ = ffesymbol_kindtype (ffecom_primary_entry_);
10195       ffecom_master_size_ = ffesymbol_size (ffecom_primary_entry_);
10196
10197       for (plist = NULL, list = ffesymbol_dummyargs (ffecom_primary_entry_);
10198            list != NULL;
10199            list = ffebld_trail (list))
10200         {
10201           arg = ffebld_head (list);
10202           if (ffebld_op (arg) != FFEBLD_opSYMTER)
10203             continue;           /* Alternate return or some such thing. */
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           plist = item;
10210         }
10211     }
10212
10213   /* If necessary, scan entry arglist for alternate returns.  Do this scan
10214      apparently redundantly (it's done below to UNIONize the arglists) so
10215      that we don't complain about RETURN 1 if an offending ENTRY is the only
10216      one with an alternate return.  */
10217
10218   if (!ffecom_is_altreturning_)
10219     {
10220       for (list = ffesymbol_dummyargs (entry);
10221            list != NULL;
10222            list = ffebld_trail (list))
10223         {
10224           arg = ffebld_head (list);
10225           if (ffebld_op (arg) == FFEBLD_opSTAR)
10226             {
10227               ffecom_is_altreturning_ = TRUE;
10228               break;
10229             }
10230         }
10231     }
10232
10233   /* Now check type compatibility. */
10234
10235   switch (ffecom_master_bt_)
10236     {
10237     case FFEINFO_basictypeNONE:
10238       ok = (bt != FFEINFO_basictypeCHARACTER);
10239       break;
10240
10241     case FFEINFO_basictypeCHARACTER:
10242       ok
10243         = (bt == FFEINFO_basictypeCHARACTER)
10244         && (kt == ffecom_master_kt_)
10245         && (size == ffecom_master_size_);
10246       break;
10247
10248     case FFEINFO_basictypeANY:
10249       return FALSE;             /* Just don't bother. */
10250
10251     default:
10252       if (bt == FFEINFO_basictypeCHARACTER)
10253         {
10254           ok = FALSE;
10255           break;
10256         }
10257       ok = TRUE;
10258       if ((bt != ffecom_master_bt_) || (kt != ffecom_master_kt_))
10259         {
10260           ffecom_master_bt_ = FFEINFO_basictypeNONE;
10261           ffecom_master_kt_ = FFEINFO_kindtypeNONE;
10262         }
10263       break;
10264     }
10265
10266   if (!ok)
10267     {
10268       ffebad_start (FFEBAD_ENTRY_CONFLICTS);
10269       ffest_ffebad_here_current_stmt (0);
10270       ffebad_finish ();
10271       return FALSE;             /* Can't handle entrypoint. */
10272     }
10273
10274   /* Entrypoint type compatible with previous types. */
10275
10276   ++ffecom_num_entrypoints_;
10277
10278   /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
10279
10280   for (list = ffesymbol_dummyargs (entry);
10281        list != NULL;
10282        list = ffebld_trail (list))
10283     {
10284       arg = ffebld_head (list);
10285       if (ffebld_op (arg) != FFEBLD_opSYMTER)
10286         continue;               /* Alternate return or some such thing. */
10287       s = ffebld_symter (arg);
10288       for (plist = NULL, mlist = ffecom_master_arglist_;
10289            mlist != NULL;
10290            plist = mlist, mlist = ffebld_trail (mlist))
10291         {                       /* plist points to previous item for easy
10292                                    appending of arg. */
10293           if (ffebld_symter (ffebld_head (mlist)) == s)
10294             break;              /* Already have this arg in the master list. */
10295         }
10296       if (mlist != NULL)
10297         continue;               /* Already have this arg in the master list. */
10298
10299       /* Append this arg to the master list. */
10300
10301       item = ffebld_new_item (arg, NULL);
10302       if (plist == NULL)
10303         ffecom_master_arglist_ = item;
10304       else
10305         ffebld_set_trail (plist, item);
10306     }
10307
10308   return TRUE;
10309 }
10310
10311 #endif
10312 /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
10313
10314    ffesymbol s;  // the ENTRY point itself
10315    ffecom_2pass_do_entrypoint(s);
10316
10317    Does whatever compiler needs to do to make the entrypoint actually
10318    happen.  Must be called for each entrypoint after
10319    ffecom_finish_progunit is called.  */
10320
10321 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10322 void
10323 ffecom_2pass_do_entrypoint (ffesymbol entry)
10324 {
10325   static int mfn_num = 0;
10326   static int ent_num;
10327
10328   if (mfn_num != ffecom_num_fns_)
10329     {                           /* First entrypoint for this program unit. */
10330       ent_num = 1;
10331       mfn_num = ffecom_num_fns_;
10332       ffecom_do_entry_ (ffecom_primary_entry_, 0);
10333     }
10334   else
10335     ++ent_num;
10336
10337   --ffecom_num_entrypoints_;
10338
10339   ffecom_do_entry_ (entry, ent_num);
10340 }
10341
10342 #endif
10343
10344 /* Essentially does a "fold (build (code, type, node1, node2))" while
10345    checking for certain housekeeping things.  Always sets
10346    TREE_SIDE_EFFECTS.  */
10347
10348 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10349 tree
10350 ffecom_2s (enum tree_code code, tree type, tree node1,
10351            tree node2)
10352 {
10353   tree item;
10354
10355   if ((node1 == error_mark_node)
10356       || (node2 == error_mark_node)
10357       || (type == error_mark_node))
10358     return error_mark_node;
10359
10360   item = build (code, type, node1, node2);
10361   TREE_SIDE_EFFECTS (item) = 1;
10362   return fold (item);
10363 }
10364
10365 #endif
10366 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10367    checking for certain housekeeping things.  */
10368
10369 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10370 tree
10371 ffecom_3 (enum tree_code code, tree type, tree node1,
10372           tree node2, tree node3)
10373 {
10374   tree item;
10375
10376   if ((node1 == error_mark_node)
10377       || (node2 == error_mark_node)
10378       || (node3 == error_mark_node)
10379       || (type == error_mark_node))
10380     return error_mark_node;
10381
10382   item = build (code, type, node1, node2, node3);
10383   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2)
10384       || (node3 != NULL_TREE && TREE_SIDE_EFFECTS (node3)))
10385     TREE_SIDE_EFFECTS (item) = 1;
10386   return fold (item);
10387 }
10388
10389 #endif
10390 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10391    checking for certain housekeeping things.  Always sets
10392    TREE_SIDE_EFFECTS.  */
10393
10394 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10395 tree
10396 ffecom_3s (enum tree_code code, tree type, tree node1,
10397            tree node2, tree node3)
10398 {
10399   tree item;
10400
10401   if ((node1 == error_mark_node)
10402       || (node2 == error_mark_node)
10403       || (node3 == error_mark_node)
10404       || (type == error_mark_node))
10405     return error_mark_node;
10406
10407   item = build (code, type, node1, node2, node3);
10408   TREE_SIDE_EFFECTS (item) = 1;
10409   return fold (item);
10410 }
10411
10412 #endif
10413
10414 /* ffecom_arg_expr -- Transform argument expr into gcc tree
10415
10416    See use by ffecom_list_expr.
10417
10418    If expression is NULL, returns an integer zero tree.  If it is not
10419    a CHARACTER expression, returns whatever ffecom_expr
10420    returns and sets the length return value to NULL_TREE.  Otherwise
10421    generates code to evaluate the character expression, returns the proper
10422    pointer to the result, but does NOT set the length return value to a tree
10423    that specifies the length of the result.  (In other words, the length
10424    variable is always set to NULL_TREE, because a length is never passed.)
10425
10426    21-Dec-91  JCB  1.1
10427       Don't set returned length, since nobody needs it (yet; someday if
10428       we allow CHARACTER*(*) dummies to statement functions, we'll need
10429       it).  */
10430
10431 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10432 tree
10433 ffecom_arg_expr (ffebld expr, tree *length)
10434 {
10435   tree ign;
10436
10437   *length = NULL_TREE;
10438
10439   if (expr == NULL)
10440     return integer_zero_node;
10441
10442   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10443     return ffecom_expr (expr);
10444
10445   return ffecom_arg_ptr_to_expr (expr, &ign);
10446 }
10447
10448 #endif
10449 /* Transform expression into constant argument-pointer-to-expression tree.
10450
10451    If the expression can be transformed into a argument-pointer-to-expression
10452    tree that is constant, that is done, and the tree returned.  Else
10453    NULL_TREE is returned.
10454
10455    That way, a caller can attempt to provide compile-time initialization
10456    of a variable and, if that fails, *then* choose to start a new block
10457    and resort to using temporaries, as appropriate.  */
10458
10459 tree
10460 ffecom_arg_ptr_to_const_expr (ffebld expr, tree *length)
10461 {
10462   if (! expr)
10463     return integer_zero_node;
10464
10465   if (ffebld_op (expr) == FFEBLD_opANY)
10466     {
10467       if (length)
10468         *length = error_mark_node;
10469       return error_mark_node;
10470     }
10471
10472   if (ffebld_arity (expr) == 0
10473       && (ffebld_op (expr) != FFEBLD_opSYMTER
10474           || ffebld_where (expr) == FFEINFO_whereCOMMON
10475           || ffebld_where (expr) == FFEINFO_whereGLOBAL
10476           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10477     {
10478       tree t;
10479
10480       t = ffecom_arg_ptr_to_expr (expr, length);
10481       assert (TREE_CONSTANT (t));
10482       assert (! length || TREE_CONSTANT (*length));
10483       return t;
10484     }
10485
10486   if (length
10487       && ffebld_size (expr) != FFETARGET_charactersizeNONE)
10488     *length = build_int_2 (ffebld_size (expr), 0);
10489   else if (length)
10490     *length = NULL_TREE;
10491   return NULL_TREE;
10492 }
10493
10494 /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
10495
10496    See use by ffecom_list_ptr_to_expr.
10497
10498    If expression is NULL, returns an integer zero tree.  If it is not
10499    a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10500    returns and sets the length return value to NULL_TREE.  Otherwise
10501    generates code to evaluate the character expression, returns the proper
10502    pointer to the result, AND sets the length return value to a tree that
10503    specifies the length of the result.
10504
10505    If the length argument is NULL, this is a slightly special
10506    case of building a FORMAT expression, that is, an expression that
10507    will be used at run time without regard to length.  For the current
10508    implementation, which uses the libf2c library, this means it is nice
10509    to append a null byte to the end of the expression, where feasible,
10510    to make sure any diagnostic about the FORMAT string terminates at
10511    some useful point.
10512
10513    For now, treat %REF(char-expr) as the same as char-expr with a NULL
10514    length argument.  This might even be seen as a feature, if a null
10515    byte can always be appended.  */
10516
10517 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10518 tree
10519 ffecom_arg_ptr_to_expr (ffebld expr, tree *length)
10520 {
10521   tree item;
10522   tree ign_length;
10523   ffecomConcatList_ catlist;
10524
10525   if (length != NULL)
10526     *length = NULL_TREE;
10527
10528   if (expr == NULL)
10529     return integer_zero_node;
10530
10531   switch (ffebld_op (expr))
10532     {
10533     case FFEBLD_opPERCENT_VAL:
10534       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10535         return ffecom_expr (ffebld_left (expr));
10536       {
10537         tree temp_exp;
10538         tree temp_length;
10539
10540         temp_exp = ffecom_arg_ptr_to_expr (ffebld_left (expr), &temp_length);
10541         if (temp_exp == error_mark_node)
10542           return error_mark_node;
10543
10544         return ffecom_1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (temp_exp)),
10545                          temp_exp);
10546       }
10547
10548     case FFEBLD_opPERCENT_REF:
10549       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10550         return ffecom_ptr_to_expr (ffebld_left (expr));
10551       if (length != NULL)
10552         {
10553           ign_length = NULL_TREE;
10554           length = &ign_length;
10555         }
10556       expr = ffebld_left (expr);
10557       break;
10558
10559     case FFEBLD_opPERCENT_DESCR:
10560       switch (ffeinfo_basictype (ffebld_info (expr)))
10561         {
10562 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10563         case FFEINFO_basictypeHOLLERITH:
10564 #endif
10565         case FFEINFO_basictypeCHARACTER:
10566           break;                /* Passed by descriptor anyway. */
10567
10568         default:
10569           item = ffecom_ptr_to_expr (expr);
10570           if (item != error_mark_node)
10571             *length = TYPE_SIZE (TREE_TYPE (TREE_TYPE (item)));
10572           break;
10573         }
10574       break;
10575
10576     default:
10577       break;
10578     }
10579
10580 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10581   if ((ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeHOLLERITH)
10582       && (length != NULL))
10583     {                           /* Pass Hollerith by descriptor. */
10584       ffetargetHollerith h;
10585
10586       assert (ffebld_op (expr) == FFEBLD_opCONTER);
10587       h = ffebld_cu_val_hollerith (ffebld_constant_union
10588                                    (ffebld_conter (expr)));
10589       *length
10590         = build_int_2 (h.length, 0);
10591       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10592     }
10593 #endif
10594
10595   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10596     return ffecom_ptr_to_expr (expr);
10597
10598   assert (ffeinfo_kindtype (ffebld_info (expr))
10599           == FFEINFO_kindtypeCHARACTER1);
10600
10601   while (ffebld_op (expr) == FFEBLD_opPAREN)
10602     expr = ffebld_left (expr);
10603
10604   catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
10605   switch (ffecom_concat_list_count_ (catlist))
10606     {
10607     case 0:                     /* Shouldn't happen, but in case it does... */
10608       if (length != NULL)
10609         {
10610           *length = ffecom_f2c_ftnlen_zero_node;
10611           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10612         }
10613       ffecom_concat_list_kill_ (catlist);
10614       return null_pointer_node;
10615
10616     case 1:                     /* The (fairly) easy case. */
10617       if (length == NULL)
10618         ffecom_char_args_with_null_ (&item, &ign_length,
10619                                      ffecom_concat_list_expr_ (catlist, 0));
10620       else
10621         ffecom_char_args_ (&item, length,
10622                            ffecom_concat_list_expr_ (catlist, 0));
10623       ffecom_concat_list_kill_ (catlist);
10624       assert (item != NULL_TREE);
10625       return item;
10626
10627     default:                    /* Must actually concatenate things. */
10628       break;
10629     }
10630
10631   {
10632     int count = ffecom_concat_list_count_ (catlist);
10633     int i;
10634     tree lengths;
10635     tree items;
10636     tree length_array;
10637     tree item_array;
10638     tree citem;
10639     tree clength;
10640     tree temporary;
10641     tree num;
10642     tree known_length;
10643     ffetargetCharacterSize sz;
10644
10645     sz = ffecom_concat_list_maxlen_ (catlist);
10646     /* ~~Kludge! */
10647     assert (sz != FFETARGET_charactersizeNONE);
10648
10649 #ifdef HOHO
10650     length_array
10651       = lengths
10652       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
10653                              FFETARGET_charactersizeNONE, count, TRUE);
10654     item_array
10655       = items
10656       = ffecom_push_tempvar (ffecom_f2c_address_type_node,
10657                              FFETARGET_charactersizeNONE, count, TRUE);
10658     temporary = ffecom_push_tempvar (char_type_node,
10659                                      sz, -1, TRUE);
10660 #else
10661     {
10662       tree hook;
10663
10664       hook = ffebld_nonter_hook (expr);
10665       assert (hook);
10666       assert (TREE_CODE (hook) == TREE_VEC);
10667       assert (TREE_VEC_LENGTH (hook) == 3);
10668       length_array = lengths = TREE_VEC_ELT (hook, 0);
10669       item_array = items = TREE_VEC_ELT (hook, 1);
10670       temporary = TREE_VEC_ELT (hook, 2);
10671     }
10672 #endif
10673
10674     known_length = ffecom_f2c_ftnlen_zero_node;
10675
10676     for (i = 0; i < count; ++i)
10677       {
10678         if ((i == count)
10679             && (length == NULL))
10680           ffecom_char_args_with_null_ (&citem, &clength,
10681                                        ffecom_concat_list_expr_ (catlist, i));
10682         else
10683           ffecom_char_args_ (&citem, &clength,
10684                              ffecom_concat_list_expr_ (catlist, i));
10685         if ((citem == error_mark_node)
10686             || (clength == error_mark_node))
10687           {
10688             ffecom_concat_list_kill_ (catlist);
10689             *length = error_mark_node;
10690             return error_mark_node;
10691           }
10692
10693         items
10694           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
10695                       ffecom_modify (void_type_node,
10696                                      ffecom_2 (ARRAY_REF,
10697                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
10698                                                item_array,
10699                                                build_int_2 (i, 0)),
10700                                      citem),
10701                       items);
10702         clength = ffecom_save_tree (clength);
10703         if (length != NULL)
10704           known_length
10705             = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
10706                         known_length,
10707                         clength);
10708         lengths
10709           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
10710                       ffecom_modify (void_type_node,
10711                                      ffecom_2 (ARRAY_REF,
10712                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
10713                                                length_array,
10714                                                build_int_2 (i, 0)),
10715                                      clength),
10716                       lengths);
10717       }
10718
10719     temporary = ffecom_1 (ADDR_EXPR,
10720                           build_pointer_type (TREE_TYPE (temporary)),
10721                           temporary);
10722
10723     item = build_tree_list (NULL_TREE, temporary);
10724     TREE_CHAIN (item)
10725       = build_tree_list (NULL_TREE,
10726                          ffecom_1 (ADDR_EXPR,
10727                                    build_pointer_type (TREE_TYPE (items)),
10728                                    items));
10729     TREE_CHAIN (TREE_CHAIN (item))
10730       = build_tree_list (NULL_TREE,
10731                          ffecom_1 (ADDR_EXPR,
10732                                    build_pointer_type (TREE_TYPE (lengths)),
10733                                    lengths));
10734     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
10735       = build_tree_list
10736         (NULL_TREE,
10737          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
10738                    convert (ffecom_f2c_ftnlen_type_node,
10739                             build_int_2 (count, 0))));
10740     num = build_int_2 (sz, 0);
10741     TREE_TYPE (num) = ffecom_f2c_ftnlen_type_node;
10742     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item))))
10743       = build_tree_list (NULL_TREE, num);
10744
10745     item = ffecom_call_gfrt (FFECOM_gfrtCAT, item, NULL_TREE);
10746     TREE_SIDE_EFFECTS (item) = 1;
10747     item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (temporary),
10748                      item,
10749                      temporary);
10750
10751     if (length != NULL)
10752       *length = known_length;
10753   }
10754
10755   ffecom_concat_list_kill_ (catlist);
10756   assert (item != NULL_TREE);
10757   return item;
10758 }
10759
10760 #endif
10761 /* Generate call to run-time function.
10762
10763    The first arg is the GNU Fortran Run-Time function index, the second
10764    arg is the list of arguments to pass to it.  Returned is the expression
10765    (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
10766    result (which may be void).  */
10767
10768 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10769 tree
10770 ffecom_call_gfrt (ffecomGfrt ix, tree args, tree hook)
10771 {
10772   return ffecom_call_ (ffecom_gfrt_tree_ (ix),
10773                        ffecom_gfrt_kindtype (ix),
10774                        ffe_is_f2c_library () && ffecom_gfrt_complex_[ix],
10775                        NULL_TREE, args, NULL_TREE, NULL,
10776                        NULL, NULL_TREE, TRUE, hook);
10777 }
10778 #endif
10779
10780 /* Transform constant-union to tree.  */
10781
10782 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10783 tree
10784 ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt,
10785                       ffeinfoKindtype kt, tree tree_type)
10786 {
10787   tree item;
10788
10789   switch (bt)
10790     {
10791     case FFEINFO_basictypeINTEGER:
10792       {
10793         int val;
10794
10795         switch (kt)
10796           {
10797 #if FFETARGET_okINTEGER1
10798           case FFEINFO_kindtypeINTEGER1:
10799             val = ffebld_cu_val_integer1 (*cu);
10800             break;
10801 #endif
10802
10803 #if FFETARGET_okINTEGER2
10804           case FFEINFO_kindtypeINTEGER2:
10805             val = ffebld_cu_val_integer2 (*cu);
10806             break;
10807 #endif
10808
10809 #if FFETARGET_okINTEGER3
10810           case FFEINFO_kindtypeINTEGER3:
10811             val = ffebld_cu_val_integer3 (*cu);
10812             break;
10813 #endif
10814
10815 #if FFETARGET_okINTEGER4
10816           case FFEINFO_kindtypeINTEGER4:
10817             val = ffebld_cu_val_integer4 (*cu);
10818             break;
10819 #endif
10820
10821           default:
10822             assert ("bad INTEGER constant kind type" == NULL);
10823             /* Fall through. */
10824           case FFEINFO_kindtypeANY:
10825             return error_mark_node;
10826           }
10827         item = build_int_2 (val, (val < 0) ? -1 : 0);
10828         TREE_TYPE (item) = tree_type;
10829       }
10830       break;
10831
10832     case FFEINFO_basictypeLOGICAL:
10833       {
10834         int val;
10835
10836         switch (kt)
10837           {
10838 #if FFETARGET_okLOGICAL1
10839           case FFEINFO_kindtypeLOGICAL1:
10840             val = ffebld_cu_val_logical1 (*cu);
10841             break;
10842 #endif
10843
10844 #if FFETARGET_okLOGICAL2
10845           case FFEINFO_kindtypeLOGICAL2:
10846             val = ffebld_cu_val_logical2 (*cu);
10847             break;
10848 #endif
10849
10850 #if FFETARGET_okLOGICAL3
10851           case FFEINFO_kindtypeLOGICAL3:
10852             val = ffebld_cu_val_logical3 (*cu);
10853             break;
10854 #endif
10855
10856 #if FFETARGET_okLOGICAL4
10857           case FFEINFO_kindtypeLOGICAL4:
10858             val = ffebld_cu_val_logical4 (*cu);
10859             break;
10860 #endif
10861
10862           default:
10863             assert ("bad LOGICAL constant kind type" == NULL);
10864             /* Fall through. */
10865           case FFEINFO_kindtypeANY:
10866             return error_mark_node;
10867           }
10868         item = build_int_2 (val, (val < 0) ? -1 : 0);
10869         TREE_TYPE (item) = tree_type;
10870       }
10871       break;
10872
10873     case FFEINFO_basictypeREAL:
10874       {
10875         REAL_VALUE_TYPE val;
10876
10877         switch (kt)
10878           {
10879 #if FFETARGET_okREAL1
10880           case FFEINFO_kindtypeREAL1:
10881             val = ffetarget_value_real1 (ffebld_cu_val_real1 (*cu));
10882             break;
10883 #endif
10884
10885 #if FFETARGET_okREAL2
10886           case FFEINFO_kindtypeREAL2:
10887             val = ffetarget_value_real2 (ffebld_cu_val_real2 (*cu));
10888             break;
10889 #endif
10890
10891 #if FFETARGET_okREAL3
10892           case FFEINFO_kindtypeREAL3:
10893             val = ffetarget_value_real3 (ffebld_cu_val_real3 (*cu));
10894             break;
10895 #endif
10896
10897 #if FFETARGET_okREAL4
10898           case FFEINFO_kindtypeREAL4:
10899             val = ffetarget_value_real4 (ffebld_cu_val_real4 (*cu));
10900             break;
10901 #endif
10902
10903           default:
10904             assert ("bad REAL constant kind type" == NULL);
10905             /* Fall through. */
10906           case FFEINFO_kindtypeANY:
10907             return error_mark_node;
10908           }
10909         item = build_real (tree_type, val);
10910       }
10911       break;
10912
10913     case FFEINFO_basictypeCOMPLEX:
10914       {
10915         REAL_VALUE_TYPE real;
10916         REAL_VALUE_TYPE imag;
10917         tree el_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
10918
10919         switch (kt)
10920           {
10921 #if FFETARGET_okCOMPLEX1
10922           case FFEINFO_kindtypeREAL1:
10923             real = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).real);
10924             imag = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).imaginary);
10925             break;
10926 #endif
10927
10928 #if FFETARGET_okCOMPLEX2
10929           case FFEINFO_kindtypeREAL2:
10930             real = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).real);
10931             imag = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).imaginary);
10932             break;
10933 #endif
10934
10935 #if FFETARGET_okCOMPLEX3
10936           case FFEINFO_kindtypeREAL3:
10937             real = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).real);
10938             imag = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).imaginary);
10939             break;
10940 #endif
10941
10942 #if FFETARGET_okCOMPLEX4
10943           case FFEINFO_kindtypeREAL4:
10944             real = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).real);
10945             imag = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).imaginary);
10946             break;
10947 #endif
10948
10949           default:
10950             assert ("bad REAL constant kind type" == NULL);
10951             /* Fall through. */
10952           case FFEINFO_kindtypeANY:
10953             return error_mark_node;
10954           }
10955         item = ffecom_build_complex_constant_ (tree_type,
10956                                                build_real (el_type, real),
10957                                                build_real (el_type, imag));
10958       }
10959       break;
10960
10961     case FFEINFO_basictypeCHARACTER:
10962       {                         /* Happens only in DATA and similar contexts. */
10963         ffetargetCharacter1 val;
10964
10965         switch (kt)
10966           {
10967 #if FFETARGET_okCHARACTER1
10968           case FFEINFO_kindtypeLOGICAL1:
10969             val = ffebld_cu_val_character1 (*cu);
10970             break;
10971 #endif
10972
10973           default:
10974             assert ("bad CHARACTER constant kind type" == NULL);
10975             /* Fall through. */
10976           case FFEINFO_kindtypeANY:
10977             return error_mark_node;
10978           }
10979         item = build_string (ffetarget_length_character1 (val),
10980                              ffetarget_text_character1 (val));
10981         TREE_TYPE (item)
10982           = build_type_variant (build_array_type (char_type_node,
10983                                                   build_range_type
10984                                                   (integer_type_node,
10985                                                    integer_one_node,
10986                                                    build_int_2
10987                                                 (ffetarget_length_character1
10988                                                  (val), 0))),
10989                                 1, 0);
10990       }
10991       break;
10992
10993     case FFEINFO_basictypeHOLLERITH:
10994       {
10995         ffetargetHollerith h;
10996
10997         h = ffebld_cu_val_hollerith (*cu);
10998
10999         /* If not at least as wide as default INTEGER, widen it.  */
11000         if (h.length >= FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE)
11001           item = build_string (h.length, h.text);
11002         else
11003           {
11004             char str[FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE];
11005
11006             memcpy (str, h.text, h.length);
11007             memset (&str[h.length], ' ',
11008                     FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE
11009                     - h.length);
11010             item = build_string (FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE,
11011                                  str);
11012           }
11013         TREE_TYPE (item)
11014           = build_type_variant (build_array_type (char_type_node,
11015                                                   build_range_type
11016                                                   (integer_type_node,
11017                                                    integer_one_node,
11018                                                    build_int_2
11019                                                    (h.length, 0))),
11020                                 1, 0);
11021       }
11022       break;
11023
11024     case FFEINFO_basictypeTYPELESS:
11025       {
11026         ffetargetInteger1 ival;
11027         ffetargetTypeless tless;
11028         ffebad error;
11029
11030         tless = ffebld_cu_val_typeless (*cu);
11031         error = ffetarget_convert_integer1_typeless (&ival, tless);
11032         assert (error == FFEBAD);
11033
11034         item = build_int_2 ((int) ival, 0);
11035       }
11036       break;
11037
11038     default:
11039       assert ("not yet on constant type" == NULL);
11040       /* Fall through. */
11041     case FFEINFO_basictypeANY:
11042       return error_mark_node;
11043     }
11044
11045   TREE_CONSTANT (item) = 1;
11046
11047   return item;
11048 }
11049
11050 #endif
11051
11052 /* Transform expression into constant tree.
11053
11054    If the expression can be transformed into a tree that is constant,
11055    that is done, and the tree returned.  Else NULL_TREE is returned.
11056
11057    That way, a caller can attempt to provide compile-time initialization
11058    of a variable and, if that fails, *then* choose to start a new block
11059    and resort to using temporaries, as appropriate.  */
11060
11061 tree
11062 ffecom_const_expr (ffebld expr)
11063 {
11064   if (! expr)
11065     return integer_zero_node;
11066
11067   if (ffebld_op (expr) == FFEBLD_opANY)
11068     return error_mark_node;
11069
11070   if (ffebld_arity (expr) == 0
11071       && (ffebld_op (expr) != FFEBLD_opSYMTER
11072 #if NEWCOMMON
11073           /* ~~Enable once common/equivalence is handled properly?  */
11074           || ffebld_where (expr) == FFEINFO_whereCOMMON
11075 #endif
11076           || ffebld_where (expr) == FFEINFO_whereGLOBAL
11077           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
11078     {
11079       tree t;
11080
11081       t = ffecom_expr (expr);
11082       assert (TREE_CONSTANT (t));
11083       return t;
11084     }
11085
11086   return NULL_TREE;
11087 }
11088
11089 /* Handy way to make a field in a struct/union.  */
11090
11091 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11092 tree
11093 ffecom_decl_field (tree context, tree prevfield,
11094                    const char *name, tree type)
11095 {
11096   tree field;
11097
11098   field = build_decl (FIELD_DECL, get_identifier (name), type);
11099   DECL_CONTEXT (field) = context;
11100   DECL_FRAME_SIZE (field) = 0;
11101   if (prevfield != NULL_TREE)
11102     TREE_CHAIN (prevfield) = field;
11103
11104   return field;
11105 }
11106
11107 #endif
11108
11109 void
11110 ffecom_close_include (FILE *f)
11111 {
11112 #if FFECOM_GCC_INCLUDE
11113   ffecom_close_include_ (f);
11114 #endif
11115 }
11116
11117 int
11118 ffecom_decode_include_option (char *spec)
11119 {
11120 #if FFECOM_GCC_INCLUDE
11121   return ffecom_decode_include_option_ (spec);
11122 #else
11123   return 1;
11124 #endif
11125 }
11126
11127 /* End a compound statement (block).  */
11128
11129 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11130 tree
11131 ffecom_end_compstmt (void)
11132 {
11133   return bison_rule_compstmt_ ();
11134 }
11135 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
11136
11137 /* ffecom_end_transition -- Perform end transition on all symbols
11138
11139    ffecom_end_transition();
11140
11141    Calls ffecom_sym_end_transition for each global and local symbol.  */
11142
11143 void
11144 ffecom_end_transition ()
11145 {
11146 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11147   ffebld item;
11148 #endif
11149
11150   if (ffe_is_ffedebug ())
11151     fprintf (dmpout, "; end_stmt_transition\n");
11152
11153 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11154   ffecom_list_blockdata_ = NULL;
11155   ffecom_list_common_ = NULL;
11156 #endif
11157
11158   ffesymbol_drive (ffecom_sym_end_transition);
11159   if (ffe_is_ffedebug ())
11160     {
11161       ffestorag_report ();
11162 #if FFECOM_targetCURRENT == FFECOM_targetFFE
11163       ffesymbol_report_all ();
11164 #endif
11165     }
11166
11167 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11168   ffecom_start_progunit_ ();
11169
11170   for (item = ffecom_list_blockdata_;
11171        item != NULL;
11172        item = ffebld_trail (item))
11173     {
11174       ffebld callee;
11175       ffesymbol s;
11176       tree dt;
11177       tree t;
11178       tree var;
11179       int yes;
11180       static int number = 0;
11181
11182       callee = ffebld_head (item);
11183       s = ffebld_symter (callee);
11184       t = ffesymbol_hook (s).decl_tree;
11185       if (t == NULL_TREE)
11186         {
11187           s = ffecom_sym_transform_ (s);
11188           t = ffesymbol_hook (s).decl_tree;
11189         }
11190
11191       yes = suspend_momentary ();
11192
11193       dt = build_pointer_type (TREE_TYPE (t));
11194
11195       var = build_decl (VAR_DECL,
11196                         ffecom_get_invented_identifier ("__g77_forceload_%d",
11197                                                         NULL, number++),
11198                         dt);
11199       DECL_EXTERNAL (var) = 0;
11200       TREE_STATIC (var) = 1;
11201       TREE_PUBLIC (var) = 0;
11202       DECL_INITIAL (var) = error_mark_node;
11203       TREE_USED (var) = 1;
11204
11205       var = start_decl (var, FALSE);
11206
11207       t = ffecom_1 (ADDR_EXPR, dt, t);
11208
11209       finish_decl (var, t, FALSE);
11210
11211       resume_momentary (yes);
11212     }
11213
11214   /* This handles any COMMON areas that weren't referenced but have, for
11215      example, important initial data.  */
11216
11217   for (item = ffecom_list_common_;
11218        item != NULL;
11219        item = ffebld_trail (item))
11220     ffecom_transform_common_ (ffebld_symter (ffebld_head (item)));
11221
11222   ffecom_list_common_ = NULL;
11223 #endif
11224 }
11225
11226 /* ffecom_exec_transition -- Perform exec transition on all symbols
11227
11228    ffecom_exec_transition();
11229
11230    Calls ffecom_sym_exec_transition for each global and local symbol.
11231    Make sure error updating not inhibited.  */
11232
11233 void
11234 ffecom_exec_transition ()
11235 {
11236   bool inhibited;
11237
11238   if (ffe_is_ffedebug ())
11239     fprintf (dmpout, "; exec_stmt_transition\n");
11240
11241   inhibited = ffebad_inhibit ();
11242   ffebad_set_inhibit (FALSE);
11243
11244   ffesymbol_drive (ffecom_sym_exec_transition); /* Don't retract! */
11245   ffeequiv_exec_transition ();  /* Handle all pending EQUIVALENCEs. */
11246   if (ffe_is_ffedebug ())
11247     {
11248       ffestorag_report ();
11249 #if FFECOM_targetCURRENT == FFECOM_targetFFE
11250       ffesymbol_report_all ();
11251 #endif
11252     }
11253
11254   if (inhibited)
11255     ffebad_set_inhibit (TRUE);
11256 }
11257
11258 /* Handle assignment statement.
11259
11260    Convert dest and source using ffecom_expr, then join them
11261    with an ASSIGN op and pass the whole thing to expand_expr_stmt.  */
11262
11263 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11264 void
11265 ffecom_expand_let_stmt (ffebld dest, ffebld source)
11266 {
11267   tree dest_tree;
11268   tree dest_length;
11269   tree source_tree;
11270   tree expr_tree;
11271
11272   if (ffeinfo_basictype (ffebld_info (dest)) != FFEINFO_basictypeCHARACTER)
11273     {
11274       bool dest_used;
11275       tree assign_temp;
11276
11277       /* This attempts to replicate the test below, but must not be
11278          true when the test below is false.  (Always err on the side
11279          of creating unused temporaries, to avoid ICEs.)  */
11280       if (ffebld_op (dest) != FFEBLD_opSYMTER
11281           || ((dest_tree = ffesymbol_hook (ffebld_symter (dest)).decl_tree)
11282               && (TREE_CODE (dest_tree) != VAR_DECL
11283                   || TREE_ADDRESSABLE (dest_tree))))
11284         {
11285           ffecom_prepare_expr_ (source, dest);
11286           dest_used = TRUE;
11287         }
11288       else
11289         {
11290           ffecom_prepare_expr_ (source, NULL);
11291           dest_used = FALSE;
11292         }
11293
11294       ffecom_prepare_expr_w (NULL_TREE, dest);
11295
11296       /* For COMPLEX assignment like C1=C2, if partial overlap is possible,
11297          create a temporary through which the assignment is to take place,
11298          since MODIFY_EXPR doesn't handle partial overlap properly.  */
11299       if (ffebld_basictype (dest) == FFEINFO_basictypeCOMPLEX
11300           && ffecom_possible_partial_overlap_ (dest, source))
11301         {
11302           assign_temp = ffecom_make_tempvar ("complex_let",
11303                                              ffecom_tree_type
11304                                              [ffebld_basictype (dest)]
11305                                              [ffebld_kindtype (dest)],
11306                                              FFETARGET_charactersizeNONE,
11307                                              -1);
11308         }
11309       else
11310         assign_temp = NULL_TREE;
11311
11312       ffecom_prepare_end ();
11313
11314       dest_tree = ffecom_expr_w (NULL_TREE, dest);
11315       if (dest_tree == error_mark_node)
11316         return;
11317
11318       if ((TREE_CODE (dest_tree) != VAR_DECL)
11319           || TREE_ADDRESSABLE (dest_tree))
11320         source_tree = ffecom_expr_ (source, dest_tree, dest, &dest_used,
11321                                     FALSE, FALSE);
11322       else
11323         {
11324           assert (! dest_used);
11325           dest_used = FALSE;
11326           source_tree = ffecom_expr (source);
11327         }
11328       if (source_tree == error_mark_node)
11329         return;
11330
11331       if (dest_used)
11332         expr_tree = source_tree;
11333       else if (assign_temp)
11334         {
11335 #ifdef MOVE_EXPR
11336           /* The back end understands a conceptual move (evaluate source;
11337              store into dest), so use that, in case it can determine
11338              that it is going to use, say, two registers as temporaries
11339              anyway.  So don't use the temp (and someday avoid generating
11340              it, once this code starts triggering regularly).  */
11341           expr_tree = ffecom_2s (MOVE_EXPR, void_type_node,
11342                                  dest_tree,
11343                                  source_tree);
11344 #else
11345           expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11346                                  assign_temp,
11347                                  source_tree);
11348           expand_expr_stmt (expr_tree);
11349           expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11350                                  dest_tree,
11351                                  assign_temp);
11352 #endif
11353         }
11354       else
11355         expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11356                                dest_tree,
11357                                source_tree);
11358
11359       expand_expr_stmt (expr_tree);
11360       return;
11361     }
11362
11363   ffecom_prepare_let_char_ (ffebld_size_known (dest), source);
11364   ffecom_prepare_expr_w (NULL_TREE, dest);
11365
11366   ffecom_prepare_end ();
11367
11368   ffecom_char_args_ (&dest_tree, &dest_length, dest);
11369   ffecom_let_char_ (dest_tree, dest_length, ffebld_size_known (dest),
11370                     source);
11371 }
11372
11373 #endif
11374 /* ffecom_expr -- Transform expr into gcc tree
11375
11376    tree t;
11377    ffebld expr;  // FFE expression.
11378    tree = ffecom_expr(expr);
11379
11380    Recursive descent on expr while making corresponding tree nodes and
11381    attaching type info and such.  */
11382
11383 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11384 tree
11385 ffecom_expr (ffebld expr)
11386 {
11387   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, FALSE, FALSE);
11388 }
11389
11390 #endif
11391 /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT.  */
11392
11393 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11394 tree
11395 ffecom_expr_assign (ffebld expr)
11396 {
11397   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
11398 }
11399
11400 #endif
11401 /* Like ffecom_expr_rw, but return tree usable for ASSIGN.  */
11402
11403 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11404 tree
11405 ffecom_expr_assign_w (ffebld expr)
11406 {
11407   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
11408 }
11409
11410 #endif
11411 /* Transform expr for use as into read/write tree and stabilize the
11412    reference.  Not for use on CHARACTER expressions.
11413
11414    Recursive descent on expr while making corresponding tree nodes and
11415    attaching type info and such.  */
11416
11417 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11418 tree
11419 ffecom_expr_rw (tree type, ffebld expr)
11420 {
11421   assert (expr != NULL);
11422   /* Different target types not yet supported.  */
11423   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
11424
11425   return stabilize_reference (ffecom_expr (expr));
11426 }
11427
11428 #endif
11429 /* Transform expr for use as into write tree and stabilize the
11430    reference.  Not for use on CHARACTER expressions.
11431
11432    Recursive descent on expr while making corresponding tree nodes and
11433    attaching type info and such.  */
11434
11435 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11436 tree
11437 ffecom_expr_w (tree type, ffebld expr)
11438 {
11439   assert (expr != NULL);
11440   /* Different target types not yet supported.  */
11441   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
11442
11443   return stabilize_reference (ffecom_expr (expr));
11444 }
11445
11446 #endif
11447 /* Do global stuff.  */
11448
11449 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11450 void
11451 ffecom_finish_compile ()
11452 {
11453   assert (ffecom_outer_function_decl_ == NULL_TREE);
11454   assert (current_function_decl == NULL_TREE);
11455
11456   ffeglobal_drive (ffecom_finish_global_);
11457 }
11458
11459 #endif
11460 /* Public entry point for front end to access finish_decl.  */
11461
11462 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11463 void
11464 ffecom_finish_decl (tree decl, tree init, bool is_top_level)
11465 {
11466   assert (!is_top_level);
11467   finish_decl (decl, init, FALSE);
11468 }
11469
11470 #endif
11471 /* Finish a program unit.  */
11472
11473 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11474 void
11475 ffecom_finish_progunit ()
11476 {
11477   ffecom_end_compstmt ();
11478
11479   ffecom_previous_function_decl_ = current_function_decl;
11480   ffecom_which_entrypoint_decl_ = NULL_TREE;
11481
11482   finish_function (0);
11483 }
11484
11485 #endif
11486 /* Wrapper for get_identifier.  pattern is sprintf-like, assumed to contain
11487    one %s if text is not NULL, assumed to contain one %d if number is
11488    not -1.  If both are assumed, the %s is assumed to precede the %d.  */
11489
11490 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11491 tree
11492 ffecom_get_invented_identifier (const char *pattern, const char *text,
11493                                 int number)
11494 {
11495   tree decl;
11496   char *nam;
11497   mallocSize lenlen;
11498   char space[66];
11499
11500   lenlen = 0;
11501   if (text)
11502     lenlen += strlen (text);
11503   if (number != -1)
11504     lenlen += 20;
11505   if (text || number != -1)
11506     {
11507       lenlen += strlen (pattern);
11508       if (lenlen > ARRAY_SIZE (space))
11509         nam = malloc_new_ks (malloc_pool_image (), pattern, lenlen);
11510       else
11511         nam = &space[0];
11512     }
11513   else
11514     {
11515       lenlen = 0;
11516       nam = (char *) pattern;
11517     }
11518
11519   if (text == NULL)
11520     {
11521       if (number != -1)
11522         sprintf (&nam[0], pattern, number);
11523     }
11524   else
11525     {
11526       if (number == -1)
11527         sprintf (&nam[0], pattern, text);
11528       else
11529         sprintf (&nam[0], pattern, text, number);
11530     }
11531
11532   decl = get_identifier (nam);
11533
11534   if (lenlen > ARRAY_SIZE (space))
11535     malloc_kill_ks (malloc_pool_image (), nam, lenlen);
11536
11537   IDENTIFIER_INVENTED (decl) = 1;
11538
11539   return decl;
11540 }
11541
11542 ffeinfoBasictype
11543 ffecom_gfrt_basictype (ffecomGfrt gfrt)
11544 {
11545   assert (gfrt < FFECOM_gfrt);
11546
11547   switch (ffecom_gfrt_type_[gfrt])
11548     {
11549     case FFECOM_rttypeVOID_:
11550     case FFECOM_rttypeVOIDSTAR_:
11551       return FFEINFO_basictypeNONE;
11552
11553     case FFECOM_rttypeFTNINT_:
11554       return FFEINFO_basictypeINTEGER;
11555
11556     case FFECOM_rttypeINTEGER_:
11557       return FFEINFO_basictypeINTEGER;
11558
11559     case FFECOM_rttypeLONGINT_:
11560       return FFEINFO_basictypeINTEGER;
11561
11562     case FFECOM_rttypeLOGICAL_:
11563       return FFEINFO_basictypeLOGICAL;
11564
11565     case FFECOM_rttypeREAL_F2C_:
11566     case FFECOM_rttypeREAL_GNU_:
11567       return FFEINFO_basictypeREAL;
11568
11569     case FFECOM_rttypeCOMPLEX_F2C_:
11570     case FFECOM_rttypeCOMPLEX_GNU_:
11571       return FFEINFO_basictypeCOMPLEX;
11572
11573     case FFECOM_rttypeDOUBLE_:
11574     case FFECOM_rttypeDOUBLEREAL_:
11575       return FFEINFO_basictypeREAL;
11576
11577     case FFECOM_rttypeDBLCMPLX_F2C_:
11578     case FFECOM_rttypeDBLCMPLX_GNU_:
11579       return FFEINFO_basictypeCOMPLEX;
11580
11581     case FFECOM_rttypeCHARACTER_:
11582       return FFEINFO_basictypeCHARACTER;
11583
11584     default:
11585       return FFEINFO_basictypeANY;
11586     }
11587 }
11588
11589 ffeinfoKindtype
11590 ffecom_gfrt_kindtype (ffecomGfrt gfrt)
11591 {
11592   assert (gfrt < FFECOM_gfrt);
11593
11594   switch (ffecom_gfrt_type_[gfrt])
11595     {
11596     case FFECOM_rttypeVOID_:
11597     case FFECOM_rttypeVOIDSTAR_:
11598       return FFEINFO_kindtypeNONE;
11599
11600     case FFECOM_rttypeFTNINT_:
11601       return FFEINFO_kindtypeINTEGER1;
11602
11603     case FFECOM_rttypeINTEGER_:
11604       return FFEINFO_kindtypeINTEGER1;
11605
11606     case FFECOM_rttypeLONGINT_:
11607       return FFEINFO_kindtypeINTEGER4;
11608
11609     case FFECOM_rttypeLOGICAL_:
11610       return FFEINFO_kindtypeLOGICAL1;
11611
11612     case FFECOM_rttypeREAL_F2C_:
11613     case FFECOM_rttypeREAL_GNU_:
11614       return FFEINFO_kindtypeREAL1;
11615
11616     case FFECOM_rttypeCOMPLEX_F2C_:
11617     case FFECOM_rttypeCOMPLEX_GNU_:
11618       return FFEINFO_kindtypeREAL1;
11619
11620     case FFECOM_rttypeDOUBLE_:
11621     case FFECOM_rttypeDOUBLEREAL_:
11622       return FFEINFO_kindtypeREAL2;
11623
11624     case FFECOM_rttypeDBLCMPLX_F2C_:
11625     case FFECOM_rttypeDBLCMPLX_GNU_:
11626       return FFEINFO_kindtypeREAL2;
11627
11628     case FFECOM_rttypeCHARACTER_:
11629       return FFEINFO_kindtypeCHARACTER1;
11630
11631     default:
11632       return FFEINFO_kindtypeANY;
11633     }
11634 }
11635
11636 void
11637 ffecom_init_0 ()
11638 {
11639   tree endlink;
11640   int i;
11641   int j;
11642   tree t;
11643   tree field;
11644   ffetype type;
11645   ffetype base_type;
11646
11647   /* This block of code comes from the now-obsolete cktyps.c.  It checks
11648      whether the compiler environment is buggy in known ways, some of which
11649      would, if not explicitly checked here, result in subtle bugs in g77.  */
11650
11651   if (ffe_is_do_internal_checks ())
11652     {
11653       static char names[][12]
11654         =
11655       {"bar", "bletch", "foo", "foobar"};
11656       char *name;
11657       unsigned long ul;
11658       double fl;
11659
11660       name = bsearch ("foo", &names[0], ARRAY_SIZE (names), sizeof (names[0]),
11661                       (int (*)()) strcmp);
11662       if (name != (char *) &names[2])
11663         {
11664           assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
11665                   == NULL);
11666           abort ();
11667         }
11668
11669       ul = strtoul ("123456789", NULL, 10);
11670       if (ul != 123456789L)
11671         {
11672           assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\
11673  in proj.h" == NULL);
11674           abort ();
11675         }
11676
11677       fl = atof ("56.789");
11678       if ((fl < 56.788) || (fl > 56.79))
11679         {
11680           assert ("atof not type double, fix your #include <stdio.h>"
11681                   == NULL);
11682           abort ();
11683         }
11684     }
11685
11686 #if FFECOM_GCC_INCLUDE
11687   ffecom_initialize_char_syntax_ ();
11688 #endif
11689
11690   ffecom_outer_function_decl_ = NULL_TREE;
11691   current_function_decl = NULL_TREE;
11692   named_labels = NULL_TREE;
11693   current_binding_level = NULL_BINDING_LEVEL;
11694   free_binding_level = NULL_BINDING_LEVEL;
11695   /* Make the binding_level structure for global names.  */
11696   pushlevel (0);
11697   global_binding_level = current_binding_level;
11698   current_binding_level->prep_state = 2;
11699
11700   /* Define `int' and `char' first so that dbx will output them first.  */
11701
11702   integer_type_node = make_signed_type (INT_TYPE_SIZE);
11703   pushdecl (build_decl (TYPE_DECL, get_identifier ("int"),
11704                         integer_type_node));
11705
11706   char_type_node = make_unsigned_type (CHAR_TYPE_SIZE);
11707   pushdecl (build_decl (TYPE_DECL, get_identifier ("char"),
11708                         char_type_node));
11709
11710   long_integer_type_node = make_signed_type (LONG_TYPE_SIZE);
11711   pushdecl (build_decl (TYPE_DECL, get_identifier ("long int"),
11712                         long_integer_type_node));
11713
11714   unsigned_type_node = make_unsigned_type (INT_TYPE_SIZE);
11715   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"),
11716                         unsigned_type_node));
11717
11718   long_unsigned_type_node = make_unsigned_type (LONG_TYPE_SIZE);
11719   pushdecl (build_decl (TYPE_DECL, get_identifier ("long unsigned int"),
11720                         long_unsigned_type_node));
11721
11722   long_long_integer_type_node = make_signed_type (LONG_LONG_TYPE_SIZE);
11723   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long int"),
11724                         long_long_integer_type_node));
11725
11726   long_long_unsigned_type_node = make_unsigned_type (LONG_LONG_TYPE_SIZE);
11727   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long unsigned int"),
11728                         long_long_unsigned_type_node));
11729
11730   short_integer_type_node = make_signed_type (SHORT_TYPE_SIZE);
11731   pushdecl (build_decl (TYPE_DECL, get_identifier ("short int"),
11732                         short_integer_type_node));
11733
11734   short_unsigned_type_node = make_unsigned_type (SHORT_TYPE_SIZE);
11735   pushdecl (build_decl (TYPE_DECL, get_identifier ("short unsigned int"),
11736                         short_unsigned_type_node));
11737
11738   /* Set the sizetype before we make other types.  This *should* be the
11739      first type we create.  */
11740
11741   set_sizetype
11742     (TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE))));
11743   ffecom_typesize_pointer_
11744     = TREE_INT_CST_LOW (TYPE_SIZE (sizetype)) / BITS_PER_UNIT;
11745
11746   error_mark_node = make_node (ERROR_MARK);
11747   TREE_TYPE (error_mark_node) = error_mark_node;
11748
11749   /* Define both `signed char' and `unsigned char'.  */
11750   signed_char_type_node = make_signed_type (CHAR_TYPE_SIZE);
11751   pushdecl (build_decl (TYPE_DECL, get_identifier ("signed char"),
11752                         signed_char_type_node));
11753
11754   unsigned_char_type_node = make_unsigned_type (CHAR_TYPE_SIZE);
11755   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"),
11756                         unsigned_char_type_node));
11757
11758   float_type_node = make_node (REAL_TYPE);
11759   TYPE_PRECISION (float_type_node) = FLOAT_TYPE_SIZE;
11760   layout_type (float_type_node);
11761   pushdecl (build_decl (TYPE_DECL, get_identifier ("float"),
11762                         float_type_node));
11763
11764   double_type_node = make_node (REAL_TYPE);
11765   TYPE_PRECISION (double_type_node) = DOUBLE_TYPE_SIZE;
11766   layout_type (double_type_node);
11767   pushdecl (build_decl (TYPE_DECL, get_identifier ("double"),
11768                         double_type_node));
11769
11770   long_double_type_node = make_node (REAL_TYPE);
11771   TYPE_PRECISION (long_double_type_node) = LONG_DOUBLE_TYPE_SIZE;
11772   layout_type (long_double_type_node);
11773   pushdecl (build_decl (TYPE_DECL, get_identifier ("long double"),
11774                         long_double_type_node));
11775
11776   complex_integer_type_node = ffecom_make_complex_type_ (integer_type_node);
11777   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex int"),
11778                         complex_integer_type_node));
11779
11780   complex_float_type_node = ffecom_make_complex_type_ (float_type_node);
11781   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex float"),
11782                         complex_float_type_node));
11783
11784   complex_double_type_node = ffecom_make_complex_type_ (double_type_node);
11785   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex double"),
11786                         complex_double_type_node));
11787
11788   complex_long_double_type_node = ffecom_make_complex_type_ (long_double_type_node);
11789   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex long double"),
11790                         complex_long_double_type_node));
11791
11792   integer_zero_node = build_int_2 (0, 0);
11793   TREE_TYPE (integer_zero_node) = integer_type_node;
11794   integer_one_node = build_int_2 (1, 0);
11795   TREE_TYPE (integer_one_node) = integer_type_node;
11796
11797   size_zero_node = build_int_2 (0, 0);
11798   TREE_TYPE (size_zero_node) = sizetype;
11799   size_one_node = build_int_2 (1, 0);
11800   TREE_TYPE (size_one_node) = sizetype;
11801
11802   void_type_node = make_node (VOID_TYPE);
11803   pushdecl (build_decl (TYPE_DECL, get_identifier ("void"),
11804                         void_type_node));
11805   layout_type (void_type_node); /* Uses integer_zero_node */
11806   /* We are not going to have real types in C with less than byte alignment,
11807      so we might as well not have any types that claim to have it.  */
11808   TYPE_ALIGN (void_type_node) = BITS_PER_UNIT;
11809
11810   null_pointer_node = build_int_2 (0, 0);
11811   TREE_TYPE (null_pointer_node) = build_pointer_type (void_type_node);
11812   layout_type (TREE_TYPE (null_pointer_node));
11813
11814   string_type_node = build_pointer_type (char_type_node);
11815
11816   ffecom_tree_fun_type_void
11817     = build_function_type (void_type_node, NULL_TREE);
11818
11819   ffecom_tree_ptr_to_fun_type_void
11820     = build_pointer_type (ffecom_tree_fun_type_void);
11821
11822   endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
11823
11824   float_ftype_float
11825     = build_function_type (float_type_node,
11826                            tree_cons (NULL_TREE, float_type_node, endlink));
11827
11828   double_ftype_double
11829     = build_function_type (double_type_node,
11830                            tree_cons (NULL_TREE, double_type_node, endlink));
11831
11832   ldouble_ftype_ldouble
11833     = build_function_type (long_double_type_node,
11834                            tree_cons (NULL_TREE, long_double_type_node,
11835                                       endlink));
11836
11837   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11838     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11839       {
11840         ffecom_tree_type[i][j] = NULL_TREE;
11841         ffecom_tree_fun_type[i][j] = NULL_TREE;
11842         ffecom_tree_ptr_to_fun_type[i][j] = NULL_TREE;
11843         ffecom_f2c_typecode_[i][j] = -1;
11844       }
11845
11846   /* Set up standard g77 types.  Note that INTEGER and LOGICAL are set
11847      to size FLOAT_TYPE_SIZE because they have to be the same size as
11848      REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
11849      Compiler options and other such stuff that change the ways these
11850      types are set should not affect this particular setup.  */
11851
11852   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1]
11853     = t = make_signed_type (FLOAT_TYPE_SIZE);
11854   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer"),
11855                         t));
11856   type = ffetype_new ();
11857   base_type = type;
11858   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER1,
11859                     type);
11860   ffetype_set_ams (type,
11861                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11862                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11863   ffetype_set_star (base_type,
11864                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11865                     type);
11866   ffetype_set_kind (base_type, 1, type);
11867   ffecom_typesize_integer1_ = ffetype_size (type);
11868   assert (ffetype_size (type) == sizeof (ffetargetInteger1));
11869
11870   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER1]
11871     = t = make_unsigned_type (FLOAT_TYPE_SIZE); /* HOLLERITH means unsigned. */
11872   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned"),
11873                         t));
11874
11875   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER2]
11876     = t = make_signed_type (CHAR_TYPE_SIZE);
11877   pushdecl (build_decl (TYPE_DECL, get_identifier ("byte"),
11878                         t));
11879   type = ffetype_new ();
11880   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER2,
11881                     type);
11882   ffetype_set_ams (type,
11883                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11884                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11885   ffetype_set_star (base_type,
11886                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11887                     type);
11888   ffetype_set_kind (base_type, 3, type);
11889   assert (ffetype_size (type) == sizeof (ffetargetInteger2));
11890
11891   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER2]
11892     = t = make_unsigned_type (CHAR_TYPE_SIZE);
11893   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned byte"),
11894                         t));
11895
11896   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER3]
11897     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11898   pushdecl (build_decl (TYPE_DECL, get_identifier ("word"),
11899                         t));
11900   type = ffetype_new ();
11901   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER3,
11902                     type);
11903   ffetype_set_ams (type,
11904                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11905                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11906   ffetype_set_star (base_type,
11907                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11908                     type);
11909   ffetype_set_kind (base_type, 6, type);
11910   assert (ffetype_size (type) == sizeof (ffetargetInteger3));
11911
11912   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER3]
11913     = t = make_unsigned_type (CHAR_TYPE_SIZE * 2);
11914   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned word"),
11915                         t));
11916
11917   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER4]
11918     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11919   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer4"),
11920                         t));
11921   type = ffetype_new ();
11922   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER4,
11923                     type);
11924   ffetype_set_ams (type,
11925                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11926                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11927   ffetype_set_star (base_type,
11928                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11929                     type);
11930   ffetype_set_kind (base_type, 2, type);
11931   assert (ffetype_size (type) == sizeof (ffetargetInteger4));
11932
11933   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER4]
11934     = t = make_unsigned_type (FLOAT_TYPE_SIZE * 2);
11935   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned4"),
11936                         t));
11937
11938 #if 0
11939   if (ffe_is_do_internal_checks ()
11940       && LONG_TYPE_SIZE != FLOAT_TYPE_SIZE
11941       && LONG_TYPE_SIZE != CHAR_TYPE_SIZE
11942       && LONG_TYPE_SIZE != SHORT_TYPE_SIZE
11943       && LONG_TYPE_SIZE != LONG_LONG_TYPE_SIZE)
11944     {
11945       fprintf (stderr, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n",
11946                LONG_TYPE_SIZE);
11947     }
11948 #endif
11949
11950   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL1]
11951     = t = make_signed_type (FLOAT_TYPE_SIZE);
11952   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical"),
11953                         t));
11954   type = ffetype_new ();
11955   base_type = type;
11956   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL1,
11957                     type);
11958   ffetype_set_ams (type,
11959                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11960                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11961   ffetype_set_star (base_type,
11962                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11963                     type);
11964   ffetype_set_kind (base_type, 1, type);
11965   assert (ffetype_size (type) == sizeof (ffetargetLogical1));
11966
11967   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL2]
11968     = t = make_signed_type (CHAR_TYPE_SIZE);
11969   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical2"),
11970                         t));
11971   type = ffetype_new ();
11972   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL2,
11973                     type);
11974   ffetype_set_ams (type,
11975                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11976                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11977   ffetype_set_star (base_type,
11978                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11979                     type);
11980   ffetype_set_kind (base_type, 3, type);
11981   assert (ffetype_size (type) == sizeof (ffetargetLogical2));
11982
11983   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL3]
11984     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11985   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical3"),
11986                         t));
11987   type = ffetype_new ();
11988   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL3,
11989                     type);
11990   ffetype_set_ams (type,
11991                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11992                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11993   ffetype_set_star (base_type,
11994                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11995                     type);
11996   ffetype_set_kind (base_type, 6, type);
11997   assert (ffetype_size (type) == sizeof (ffetargetLogical3));
11998
11999   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL4]
12000     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
12001   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical4"),
12002                         t));
12003   type = ffetype_new ();
12004   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL4,
12005                     type);
12006   ffetype_set_ams (type,
12007                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
12008                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
12009   ffetype_set_star (base_type,
12010                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
12011                     type);
12012   ffetype_set_kind (base_type, 2, type);
12013   assert (ffetype_size (type) == sizeof (ffetargetLogical4));
12014
12015   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
12016     = t = make_node (REAL_TYPE);
12017   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE;
12018   pushdecl (build_decl (TYPE_DECL, get_identifier ("real"),
12019                         t));
12020   layout_type (t);
12021   type = ffetype_new ();
12022   base_type = type;
12023   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL1,
12024                     type);
12025   ffetype_set_ams (type,
12026                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
12027                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
12028   ffetype_set_star (base_type,
12029                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
12030                     type);
12031   ffetype_set_kind (base_type, 1, type);
12032   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
12033     = FFETARGET_f2cTYREAL;
12034   assert (ffetype_size (type) == sizeof (ffetargetReal1));
12035
12036   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREALDOUBLE]
12037     = t = make_node (REAL_TYPE);
12038   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE * 2;     /* Always twice REAL. */
12039   pushdecl (build_decl (TYPE_DECL, get_identifier ("double precision"),
12040                         t));
12041   layout_type (t);
12042   type = ffetype_new ();
12043   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
12044                     type);
12045   ffetype_set_ams (type,
12046                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
12047                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
12048   ffetype_set_star (base_type,
12049                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
12050                     type);
12051   ffetype_set_kind (base_type, 2, type);
12052   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]
12053     = FFETARGET_f2cTYDREAL;
12054   assert (ffetype_size (type) == sizeof (ffetargetReal2));
12055
12056   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
12057     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]);
12058   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex"),
12059                         t));
12060   type = ffetype_new ();
12061   base_type = type;
12062   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL1,
12063                     type);
12064   ffetype_set_ams (type,
12065                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
12066                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
12067   ffetype_set_star (base_type,
12068                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
12069                     type);
12070   ffetype_set_kind (base_type, 1, type);
12071   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
12072     = FFETARGET_f2cTYCOMPLEX;
12073   assert (ffetype_size (type) == sizeof (ffetargetComplex1));
12074
12075   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREALDOUBLE]
12076     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]);
12077   pushdecl (build_decl (TYPE_DECL, get_identifier ("double complex"),
12078                         t));
12079   type = ffetype_new ();
12080   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREALDOUBLE,
12081                     type);
12082   ffetype_set_ams (type,
12083                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
12084                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
12085   ffetype_set_star (base_type,
12086                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
12087                     type);
12088   ffetype_set_kind (base_type, 2,
12089                     type);
12090   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL2]
12091     = FFETARGET_f2cTYDCOMPLEX;
12092   assert (ffetype_size (type) == sizeof (ffetargetComplex2));
12093
12094   /* Make function and ptr-to-function types for non-CHARACTER types. */
12095
12096   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
12097     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
12098       {
12099         if ((t = ffecom_tree_type[i][j]) != NULL_TREE)
12100           {
12101             if (i == FFEINFO_basictypeINTEGER)
12102               {
12103                 /* Figure out the smallest INTEGER type that can hold
12104                    a pointer on this machine. */
12105                 if (GET_MODE_SIZE (TYPE_MODE (t))
12106                     >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
12107                   {
12108                     if ((ffecom_pointer_kind_ == FFEINFO_kindtypeNONE)
12109                         || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type[i][ffecom_pointer_kind_]))
12110                             > GET_MODE_SIZE (TYPE_MODE (t))))
12111                       ffecom_pointer_kind_ = j;
12112                   }
12113               }
12114             else if (i == FFEINFO_basictypeCOMPLEX)
12115               t = void_type_node;
12116             /* For f2c compatibility, REAL functions are really
12117                implemented as DOUBLE PRECISION.  */
12118             else if ((i == FFEINFO_basictypeREAL)
12119                      && (j == FFEINFO_kindtypeREAL1))
12120               t = ffecom_tree_type
12121                 [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2];
12122
12123             t = ffecom_tree_fun_type[i][j] = build_function_type (t,
12124                                                                   NULL_TREE);
12125             ffecom_tree_ptr_to_fun_type[i][j] = build_pointer_type (t);
12126           }
12127       }
12128
12129   /* Set up pointer types.  */
12130
12131   if (ffecom_pointer_kind_ == FFEINFO_basictypeNONE)
12132     fatal ("no INTEGER type can hold a pointer on this configuration");
12133   else if (0 && ffe_is_do_internal_checks ())
12134     fprintf (stderr, "Pointer type kt=%d\n", ffecom_pointer_kind_);
12135   ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER,
12136                                   FFEINFO_kindtypeINTEGERDEFAULT),
12137                     7,
12138                     ffeinfo_type (FFEINFO_basictypeINTEGER,
12139                                   ffecom_pointer_kind_));
12140
12141   if (ffe_is_ugly_assign ())
12142     ffecom_label_kind_ = ffecom_pointer_kind_;  /* Require ASSIGN etc to this. */
12143   else
12144     ffecom_label_kind_ = FFEINFO_kindtypeINTEGERDEFAULT;
12145   if (0 && ffe_is_do_internal_checks ())
12146     fprintf (stderr, "Label type kt=%d\n", ffecom_label_kind_);
12147
12148   ffecom_integer_type_node
12149     = ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1];
12150   ffecom_integer_zero_node = convert (ffecom_integer_type_node,
12151                                       integer_zero_node);
12152   ffecom_integer_one_node = convert (ffecom_integer_type_node,
12153                                      integer_one_node);
12154
12155   /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
12156      Turns out that by TYLONG, runtime/libI77/lio.h really means
12157      "whatever size an ftnint is".  For consistency and sanity,
12158      com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
12159      all are INTEGER, which we also make out of whatever back-end
12160      integer type is FLOAT_TYPE_SIZE bits wide.  This change, from
12161      LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
12162      accommodate machines like the Alpha.  Note that this suggests
12163      f2c and libf2c are missing a distinction perhaps needed on
12164      some machines between "int" and "long int".  -- burley 0.5.5 950215 */
12165
12166   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, FLOAT_TYPE_SIZE,
12167                             FFETARGET_f2cTYLONG);
12168   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, SHORT_TYPE_SIZE,
12169                             FFETARGET_f2cTYSHORT);
12170   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, CHAR_TYPE_SIZE,
12171                             FFETARGET_f2cTYINT1);
12172   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, LONG_LONG_TYPE_SIZE,
12173                             FFETARGET_f2cTYQUAD);
12174   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, FLOAT_TYPE_SIZE,
12175                             FFETARGET_f2cTYLOGICAL);
12176   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, SHORT_TYPE_SIZE,
12177                             FFETARGET_f2cTYLOGICAL2);
12178   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, CHAR_TYPE_SIZE,
12179                             FFETARGET_f2cTYLOGICAL1);
12180   /* ~~~Not really such a type in libf2c, e.g. I/O support?  */
12181   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, LONG_LONG_TYPE_SIZE,
12182                             FFETARGET_f2cTYQUAD);
12183
12184   /* CHARACTER stuff is all special-cased, so it is not handled in the above
12185      loop.  CHARACTER items are built as arrays of unsigned char.  */
12186
12187   ffecom_tree_type[FFEINFO_basictypeCHARACTER]
12188     [FFEINFO_kindtypeCHARACTER1] = t = char_type_node;
12189   type = ffetype_new ();
12190   base_type = type;
12191   ffeinfo_set_type (FFEINFO_basictypeCHARACTER,
12192                     FFEINFO_kindtypeCHARACTER1,
12193                     type);
12194   ffetype_set_ams (type,
12195                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
12196                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
12197   ffetype_set_kind (base_type, 1, type);
12198   assert (ffetype_size (type)
12199           == sizeof (((ffetargetCharacter1) { 0, NULL }).text[0]));
12200
12201   ffecom_tree_fun_type[FFEINFO_basictypeCHARACTER]
12202     [FFEINFO_kindtypeCHARACTER1] = ffecom_tree_fun_type_void;
12203   ffecom_tree_ptr_to_fun_type[FFEINFO_basictypeCHARACTER]
12204     [FFEINFO_kindtypeCHARACTER1]
12205     = ffecom_tree_ptr_to_fun_type_void;
12206   ffecom_f2c_typecode_[FFEINFO_basictypeCHARACTER][FFEINFO_kindtypeCHARACTER1]
12207     = FFETARGET_f2cTYCHAR;
12208
12209   ffecom_f2c_typecode_[FFEINFO_basictypeANY][FFEINFO_kindtypeANY]
12210     = 0;
12211
12212   /* Make multi-return-value type and fields. */
12213
12214   ffecom_multi_type_node_ = make_node (UNION_TYPE);
12215
12216   field = NULL_TREE;
12217
12218   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
12219     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
12220       {
12221         char name[30];
12222
12223         if (ffecom_tree_type[i][j] == NULL_TREE)
12224           continue;             /* Not supported. */
12225         sprintf (&name[0], "bt_%s_kt_%s",
12226                  ffeinfo_basictype_string ((ffeinfoBasictype) i),
12227                  ffeinfo_kindtype_string ((ffeinfoKindtype) j));
12228         ffecom_multi_fields_[i][j] = build_decl (FIELD_DECL,
12229                                                  get_identifier (name),
12230                                                  ffecom_tree_type[i][j]);
12231         DECL_CONTEXT (ffecom_multi_fields_[i][j])
12232           = ffecom_multi_type_node_;
12233         DECL_FRAME_SIZE (ffecom_multi_fields_[i][j]) = 0;
12234         TREE_CHAIN (ffecom_multi_fields_[i][j]) = field;
12235         field = ffecom_multi_fields_[i][j];
12236       }
12237
12238   TYPE_FIELDS (ffecom_multi_type_node_) = field;
12239   layout_type (ffecom_multi_type_node_);
12240
12241   /* Subroutines usually return integer because they might have alternate
12242      returns. */
12243
12244   ffecom_tree_subr_type
12245     = build_function_type (integer_type_node, NULL_TREE);
12246   ffecom_tree_ptr_to_subr_type
12247     = build_pointer_type (ffecom_tree_subr_type);
12248   ffecom_tree_blockdata_type
12249     = build_function_type (void_type_node, NULL_TREE);
12250
12251   builtin_function ("__builtin_sqrtf", float_ftype_float,
12252                     BUILT_IN_FSQRT, "sqrtf");
12253   builtin_function ("__builtin_fsqrt", double_ftype_double,
12254                     BUILT_IN_FSQRT, "sqrt");
12255   builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble,
12256                     BUILT_IN_FSQRT, "sqrtl");
12257   builtin_function ("__builtin_sinf", float_ftype_float,
12258                     BUILT_IN_SIN, "sinf");
12259   builtin_function ("__builtin_sin", double_ftype_double,
12260                     BUILT_IN_SIN, "sin");
12261   builtin_function ("__builtin_sinl", ldouble_ftype_ldouble,
12262                     BUILT_IN_SIN, "sinl");
12263   builtin_function ("__builtin_cosf", float_ftype_float,
12264                     BUILT_IN_COS, "cosf");
12265   builtin_function ("__builtin_cos", double_ftype_double,
12266                     BUILT_IN_COS, "cos");
12267   builtin_function ("__builtin_cosl", ldouble_ftype_ldouble,
12268                     BUILT_IN_COS, "cosl");
12269
12270 #if BUILT_FOR_270
12271   pedantic_lvalues = FALSE;
12272 #endif
12273
12274   ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node,
12275                          FFECOM_f2cINTEGER,
12276                          "integer");
12277   ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node,
12278                          FFECOM_f2cADDRESS,
12279                          "address");
12280   ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node,
12281                          FFECOM_f2cREAL,
12282                          "real");
12283   ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node,
12284                          FFECOM_f2cDOUBLEREAL,
12285                          "doublereal");
12286   ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node,
12287                          FFECOM_f2cCOMPLEX,
12288                          "complex");
12289   ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node,
12290                          FFECOM_f2cDOUBLECOMPLEX,
12291                          "doublecomplex");
12292   ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node,
12293                          FFECOM_f2cLONGINT,
12294                          "longint");
12295   ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node,
12296                          FFECOM_f2cLOGICAL,
12297                          "logical");
12298   ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node,
12299                          FFECOM_f2cFLAG,
12300                          "flag");
12301   ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node,
12302                          FFECOM_f2cFTNLEN,
12303                          "ftnlen");
12304   ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node,
12305                          FFECOM_f2cFTNINT,
12306                          "ftnint");
12307
12308   ffecom_f2c_ftnlen_zero_node
12309     = convert (ffecom_f2c_ftnlen_type_node, integer_zero_node);
12310
12311   ffecom_f2c_ftnlen_one_node
12312     = convert (ffecom_f2c_ftnlen_type_node, integer_one_node);
12313
12314   ffecom_f2c_ftnlen_two_node = build_int_2 (2, 0);
12315   TREE_TYPE (ffecom_f2c_ftnlen_two_node) = ffecom_integer_type_node;
12316
12317   ffecom_f2c_ptr_to_ftnlen_type_node
12318     = build_pointer_type (ffecom_f2c_ftnlen_type_node);
12319
12320   ffecom_f2c_ptr_to_ftnint_type_node
12321     = build_pointer_type (ffecom_f2c_ftnint_type_node);
12322
12323   ffecom_f2c_ptr_to_integer_type_node
12324     = build_pointer_type (ffecom_f2c_integer_type_node);
12325
12326   ffecom_f2c_ptr_to_real_type_node
12327     = build_pointer_type (ffecom_f2c_real_type_node);
12328
12329   ffecom_float_zero_ = build_real (float_type_node, dconst0);
12330   ffecom_double_zero_ = build_real (double_type_node, dconst0);
12331   {
12332     REAL_VALUE_TYPE point_5;
12333
12334 #ifdef REAL_ARITHMETIC
12335     REAL_ARITHMETIC (point_5, RDIV_EXPR, dconst1, dconst2);
12336 #else
12337     point_5 = .5;
12338 #endif
12339     ffecom_float_half_ = build_real (float_type_node, point_5);
12340     ffecom_double_half_ = build_real (double_type_node, point_5);
12341   }
12342
12343   /* Do "extern int xargc;".  */
12344
12345   ffecom_tree_xargc_ = build_decl (VAR_DECL,
12346                                    get_identifier ("f__xargc"),
12347                                    integer_type_node);
12348   DECL_EXTERNAL (ffecom_tree_xargc_) = 1;
12349   TREE_STATIC (ffecom_tree_xargc_) = 1;
12350   TREE_PUBLIC (ffecom_tree_xargc_) = 1;
12351   ffecom_tree_xargc_ = start_decl (ffecom_tree_xargc_, FALSE);
12352   finish_decl (ffecom_tree_xargc_, NULL_TREE, FALSE);
12353
12354 #if 0   /* This is being fixed, and seems to be working now. */
12355   if ((FLOAT_TYPE_SIZE != 32)
12356       || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))) != 32))
12357     {
12358       warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,",
12359                (int) FLOAT_TYPE_SIZE);
12360       warning ("and pointers are %d bits wide, but g77 doesn't yet work",
12361           (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))));
12362       warning ("properly unless they all are 32 bits wide.");
12363       warning ("Please keep this in mind before you report bugs.  g77 should");
12364       warning ("support non-32-bit machines better as of version 0.6.");
12365     }
12366 #endif
12367
12368 #if 0   /* Code in ste.c that would crash has been commented out. */
12369   if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
12370       < TYPE_PRECISION (string_type_node))
12371     /* I/O will probably crash.  */
12372     warning ("configuration: char * holds %d bits, but ftnlen only %d",
12373              TYPE_PRECISION (string_type_node),
12374              TYPE_PRECISION (ffecom_f2c_ftnlen_type_node));
12375 #endif
12376
12377 #if 0   /* ASSIGN-related stuff has been changed to accommodate this. */
12378   if (TYPE_PRECISION (ffecom_integer_type_node)
12379       < TYPE_PRECISION (string_type_node))
12380     /* ASSIGN 10 TO I will crash.  */
12381     warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
12382  ASSIGN statement might fail",
12383              TYPE_PRECISION (string_type_node),
12384              TYPE_PRECISION (ffecom_integer_type_node));
12385 #endif
12386 }
12387
12388 #endif
12389 /* ffecom_init_2 -- Initialize
12390
12391    ffecom_init_2();  */
12392
12393 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12394 void
12395 ffecom_init_2 ()
12396 {
12397   assert (ffecom_outer_function_decl_ == NULL_TREE);
12398   assert (current_function_decl == NULL_TREE);
12399   assert (ffecom_which_entrypoint_decl_ == NULL_TREE);
12400
12401   ffecom_master_arglist_ = NULL;
12402   ++ffecom_num_fns_;
12403   ffecom_primary_entry_ = NULL;
12404   ffecom_is_altreturning_ = FALSE;
12405   ffecom_func_result_ = NULL_TREE;
12406   ffecom_multi_retval_ = NULL_TREE;
12407 }
12408
12409 #endif
12410 /* ffecom_list_expr -- Transform list of exprs into gcc tree
12411
12412    tree t;
12413    ffebld expr;  // FFE opITEM list.
12414    tree = ffecom_list_expr(expr);
12415
12416    List of actual args is transformed into corresponding gcc backend list.  */
12417
12418 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12419 tree
12420 ffecom_list_expr (ffebld expr)
12421 {
12422   tree list;
12423   tree *plist = &list;
12424   tree trail = NULL_TREE;       /* Append char length args here. */
12425   tree *ptrail = &trail;
12426   tree length;
12427
12428   while (expr != NULL)
12429     {
12430       tree texpr = ffecom_arg_expr (ffebld_head (expr), &length);
12431
12432       if (texpr == error_mark_node)
12433         return error_mark_node;
12434
12435       *plist = build_tree_list (NULL_TREE, texpr);
12436       plist = &TREE_CHAIN (*plist);
12437       expr = ffebld_trail (expr);
12438       if (length != NULL_TREE)
12439         {
12440           *ptrail = build_tree_list (NULL_TREE, length);
12441           ptrail = &TREE_CHAIN (*ptrail);
12442         }
12443     }
12444
12445   *plist = trail;
12446
12447   return list;
12448 }
12449
12450 #endif
12451 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
12452
12453    tree t;
12454    ffebld expr;  // FFE opITEM list.
12455    tree = ffecom_list_ptr_to_expr(expr);
12456
12457    List of actual args is transformed into corresponding gcc backend list for
12458    use in calling an external procedure (vs. a statement function).  */
12459
12460 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12461 tree
12462 ffecom_list_ptr_to_expr (ffebld expr)
12463 {
12464   tree list;
12465   tree *plist = &list;
12466   tree trail = NULL_TREE;       /* Append char length args here. */
12467   tree *ptrail = &trail;
12468   tree length;
12469
12470   while (expr != NULL)
12471     {
12472       tree texpr = ffecom_arg_ptr_to_expr (ffebld_head (expr), &length);
12473
12474       if (texpr == error_mark_node)
12475         return error_mark_node;
12476
12477       *plist = build_tree_list (NULL_TREE, texpr);
12478       plist = &TREE_CHAIN (*plist);
12479       expr = ffebld_trail (expr);
12480       if (length != NULL_TREE)
12481         {
12482           *ptrail = build_tree_list (NULL_TREE, length);
12483           ptrail = &TREE_CHAIN (*ptrail);
12484         }
12485     }
12486
12487   *plist = trail;
12488
12489   return list;
12490 }
12491
12492 #endif
12493 /* Obtain gcc's LABEL_DECL tree for label.  */
12494
12495 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12496 tree
12497 ffecom_lookup_label (ffelab label)
12498 {
12499   tree glabel;
12500
12501   if (ffelab_hook (label) == NULL_TREE)
12502     {
12503       char labelname[16];
12504
12505       switch (ffelab_type (label))
12506         {
12507         case FFELAB_typeLOOPEND:
12508         case FFELAB_typeNOTLOOP:
12509         case FFELAB_typeENDIF:
12510           sprintf (labelname, "%" ffelabValue_f "u", ffelab_value (label));
12511           glabel = build_decl (LABEL_DECL, get_identifier (labelname),
12512                                void_type_node);
12513           DECL_CONTEXT (glabel) = current_function_decl;
12514           DECL_MODE (glabel) = VOIDmode;
12515           break;
12516
12517         case FFELAB_typeFORMAT:
12518           push_obstacks_nochange ();
12519           end_temporary_allocation ();
12520
12521           glabel = build_decl (VAR_DECL,
12522                                ffecom_get_invented_identifier
12523                                ("__g77_format_%d", NULL,
12524                                 (int) ffelab_value (label)),
12525                                build_type_variant (build_array_type
12526                                                    (char_type_node,
12527                                                     NULL_TREE),
12528                                                    1, 0));
12529           TREE_CONSTANT (glabel) = 1;
12530           TREE_STATIC (glabel) = 1;
12531           DECL_CONTEXT (glabel) = 0;
12532           DECL_INITIAL (glabel) = NULL;
12533           make_decl_rtl (glabel, NULL, 0);
12534           expand_decl (glabel);
12535
12536           resume_temporary_allocation ();
12537           pop_obstacks ();
12538
12539           break;
12540
12541         case FFELAB_typeANY:
12542           glabel = error_mark_node;
12543           break;
12544
12545         default:
12546           assert ("bad label type" == NULL);
12547           glabel = NULL;
12548           break;
12549         }
12550       ffelab_set_hook (label, glabel);
12551     }
12552   else
12553     {
12554       glabel = ffelab_hook (label);
12555     }
12556
12557   return glabel;
12558 }
12559
12560 #endif
12561 /* Stabilizes the arguments.  Don't use this if the lhs and rhs come from
12562    a single source specification (as in the fourth argument of MVBITS).
12563    If the type is NULL_TREE, the type of lhs is used to make the type of
12564    the MODIFY_EXPR.  */
12565
12566 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12567 tree
12568 ffecom_modify (tree newtype, tree lhs,
12569                tree rhs)
12570 {
12571   if (lhs == error_mark_node || rhs == error_mark_node)
12572     return error_mark_node;
12573
12574   if (newtype == NULL_TREE)
12575     newtype = TREE_TYPE (lhs);
12576
12577   if (TREE_SIDE_EFFECTS (lhs))
12578     lhs = stabilize_reference (lhs);
12579
12580   return ffecom_2s (MODIFY_EXPR, newtype, lhs, rhs);
12581 }
12582
12583 #endif
12584
12585 /* Register source file name.  */
12586
12587 void
12588 ffecom_file (char *name)
12589 {
12590 #if FFECOM_GCC_INCLUDE
12591   ffecom_file_ (name);
12592 #endif
12593 }
12594
12595 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
12596
12597    ffestorag st;
12598    ffecom_notify_init_storage(st);
12599
12600    Gets called when all possible units in an aggregate storage area (a LOCAL
12601    with equivalences or a COMMON) have been initialized.  The initialization
12602    info either is in ffestorag_init or, if that is NULL,
12603    ffestorag_accretion:
12604
12605    ffestorag_init may contain an opCONTER or opARRTER.  opCONTER may occur
12606    even for an array if the array is one element in length!
12607
12608    ffestorag_accretion will contain an opACCTER.  It is much like an
12609    opARRTER except it has an ffebit object in it instead of just a size.
12610    The back end can use the info in the ffebit object, if it wants, to
12611    reduce the amount of actual initialization, but in any case it should
12612    kill the ffebit object when done.  Also, set accretion to NULL but
12613    init to a non-NULL value.
12614
12615    After performing initialization, DO NOT set init to NULL, because that'll
12616    tell the front end it is ok for more initialization to happen.  Instead,
12617    set init to an opANY expression or some such thing that you can use to
12618    tell that you've already initialized the object.
12619
12620    27-Oct-91  JCB  1.1
12621       Support two-pass FFE.  */
12622
12623 void
12624 ffecom_notify_init_storage (ffestorag st)
12625 {
12626   ffebld init;                  /* The initialization expression. */
12627 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12628   ffetargetOffset size;         /* The size of the entity. */
12629   ffetargetAlign pad;           /* Its initial padding. */
12630 #endif
12631
12632   if (ffestorag_init (st) == NULL)
12633     {
12634       init = ffestorag_accretion (st);
12635       assert (init != NULL);
12636       ffestorag_set_accretion (st, NULL);
12637       ffestorag_set_accretes (st, 0);
12638
12639 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12640       /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12641       size = ffebld_accter_size (init);
12642       pad = ffebld_accter_pad (init);
12643       ffebit_kill (ffebld_accter_bits (init));
12644       ffebld_set_op (init, FFEBLD_opARRTER);
12645       ffebld_set_arrter (init, ffebld_accter (init));
12646       ffebld_arrter_set_size (init, size);
12647       ffebld_arrter_set_pad (init, size);
12648 #endif
12649
12650 #if FFECOM_TWOPASS
12651       ffestorag_set_init (st, init);
12652 #endif
12653     }
12654 #if FFECOM_ONEPASS
12655   else
12656     init = ffestorag_init (st);
12657 #endif
12658
12659 #if FFECOM_ONEPASS              /* Process the inits, wipe 'em out. */
12660   ffestorag_set_init (st, ffebld_new_any ());
12661
12662   if (ffebld_op (init) == FFEBLD_opANY)
12663     return;                     /* Oh, we already did this! */
12664
12665 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12666   {
12667     ffesymbol s;
12668
12669     if (ffestorag_symbol (st) != NULL)
12670       s = ffestorag_symbol (st);
12671     else
12672       s = ffestorag_typesymbol (st);
12673
12674     fprintf (dmpout, "= initialize_storage \"%s\" ",
12675              (s != NULL) ? ffesymbol_text (s) : "(unnamed)");
12676     ffebld_dump (init);
12677     fputc ('\n', dmpout);
12678   }
12679 #endif
12680
12681 #endif /* if FFECOM_ONEPASS */
12682 }
12683
12684 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12685
12686    ffesymbol s;
12687    ffecom_notify_init_symbol(s);
12688
12689    Gets called when all possible units in a symbol (not placed in COMMON
12690    or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12691    have been initialized.  The initialization info either is in
12692    ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12693
12694    ffesymbol_init may contain an opCONTER or opARRTER.  opCONTER may occur
12695    even for an array if the array is one element in length!
12696
12697    ffesymbol_accretion will contain an opACCTER.  It is much like an
12698    opARRTER except it has an ffebit object in it instead of just a size.
12699    The back end can use the info in the ffebit object, if it wants, to
12700    reduce the amount of actual initialization, but in any case it should
12701    kill the ffebit object when done.  Also, set accretion to NULL but
12702    init to a non-NULL value.
12703
12704    After performing initialization, DO NOT set init to NULL, because that'll
12705    tell the front end it is ok for more initialization to happen.  Instead,
12706    set init to an opANY expression or some such thing that you can use to
12707    tell that you've already initialized the object.
12708
12709    27-Oct-91  JCB  1.1
12710       Support two-pass FFE.  */
12711
12712 void
12713 ffecom_notify_init_symbol (ffesymbol s)
12714 {
12715   ffebld init;                  /* The initialization expression. */
12716 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12717   ffetargetOffset size;         /* The size of the entity. */
12718   ffetargetAlign pad;           /* Its initial padding. */
12719 #endif
12720
12721   if (ffesymbol_storage (s) == NULL)
12722     return;                     /* Do nothing until COMMON/EQUIVALENCE
12723                                    possibilities checked. */
12724
12725   if ((ffesymbol_init (s) == NULL)
12726       && ((init = ffesymbol_accretion (s)) != NULL))
12727     {
12728       ffesymbol_set_accretion (s, NULL);
12729       ffesymbol_set_accretes (s, 0);
12730
12731 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12732       /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12733       size = ffebld_accter_size (init);
12734       pad = ffebld_accter_pad (init);
12735       ffebit_kill (ffebld_accter_bits (init));
12736       ffebld_set_op (init, FFEBLD_opARRTER);
12737       ffebld_set_arrter (init, ffebld_accter (init));
12738       ffebld_arrter_set_size (init, size);
12739       ffebld_arrter_set_pad (init, size);
12740 #endif
12741
12742 #if FFECOM_TWOPASS
12743       ffesymbol_set_init (s, init);
12744 #endif
12745     }
12746 #if FFECOM_ONEPASS
12747   else
12748     init = ffesymbol_init (s);
12749 #endif
12750
12751 #if FFECOM_ONEPASS
12752   ffesymbol_set_init (s, ffebld_new_any ());
12753
12754   if (ffebld_op (init) == FFEBLD_opANY)
12755     return;                     /* Oh, we already did this! */
12756
12757 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12758   fprintf (dmpout, "= initialize_symbol \"%s\" ", ffesymbol_text (s));
12759   ffebld_dump (init);
12760   fputc ('\n', dmpout);
12761 #endif
12762
12763 #endif /* if FFECOM_ONEPASS */
12764 }
12765
12766 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12767
12768    ffesymbol s;
12769    ffecom_notify_primary_entry(s);
12770
12771    Gets called when implicit or explicit PROGRAM statement seen or when
12772    FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12773    global symbol that serves as the entry point.  */
12774
12775 void
12776 ffecom_notify_primary_entry (ffesymbol s)
12777 {
12778   ffecom_primary_entry_ = s;
12779   ffecom_primary_entry_kind_ = ffesymbol_kind (s);
12780
12781   if ((ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
12782       || (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE))
12783     ffecom_primary_entry_is_proc_ = TRUE;
12784   else
12785     ffecom_primary_entry_is_proc_ = FALSE;
12786
12787   if (!ffe_is_silent ())
12788     {
12789       if (ffecom_primary_entry_kind_ == FFEINFO_kindPROGRAM)
12790         fprintf (stderr, "%s:\n", ffesymbol_text (s));
12791       else
12792         fprintf (stderr, "  %s:\n", ffesymbol_text (s));
12793     }
12794
12795 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12796   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
12797     {
12798       ffebld list;
12799       ffebld arg;
12800
12801       for (list = ffesymbol_dummyargs (s);
12802            list != NULL;
12803            list = ffebld_trail (list))
12804         {
12805           arg = ffebld_head (list);
12806           if (ffebld_op (arg) == FFEBLD_opSTAR)
12807             {
12808               ffecom_is_altreturning_ = TRUE;
12809               break;
12810             }
12811         }
12812     }
12813 #endif
12814 }
12815
12816 FILE *
12817 ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c)
12818 {
12819 #if FFECOM_GCC_INCLUDE
12820   return ffecom_open_include_ (name, l, c);
12821 #else
12822   return fopen (name, "r");
12823 #endif
12824 }
12825
12826 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
12827
12828    tree t;
12829    ffebld expr;  // FFE expression.
12830    tree = ffecom_ptr_to_expr(expr);
12831
12832    Like ffecom_expr, but sticks address-of in front of most things.  */
12833
12834 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12835 tree
12836 ffecom_ptr_to_expr (ffebld expr)
12837 {
12838   tree item;
12839   ffeinfoBasictype bt;
12840   ffeinfoKindtype kt;
12841   ffesymbol s;
12842
12843   assert (expr != NULL);
12844
12845   switch (ffebld_op (expr))
12846     {
12847     case FFEBLD_opSYMTER:
12848       s = ffebld_symter (expr);
12849       if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
12850         {
12851           ffecomGfrt ix;
12852
12853           ix = ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr));
12854           assert (ix != FFECOM_gfrt);
12855           if ((item = ffecom_gfrt_[ix]) == NULL_TREE)
12856             {
12857               ffecom_make_gfrt_ (ix);
12858               item = ffecom_gfrt_[ix];
12859             }
12860         }
12861       else
12862         {
12863           item = ffesymbol_hook (s).decl_tree;
12864           if (item == NULL_TREE)
12865             {
12866               s = ffecom_sym_transform_ (s);
12867               item = ffesymbol_hook (s).decl_tree;
12868             }
12869         }
12870       assert (item != NULL);
12871       if (item == error_mark_node)
12872         return item;
12873       if (!ffesymbol_hook (s).addr)
12874         item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12875                          item);
12876       return item;
12877
12878     case FFEBLD_opARRAYREF:
12879       return ffecom_arrayref_ (NULL_TREE, expr, 1);
12880
12881     case FFEBLD_opCONTER:
12882
12883       bt = ffeinfo_basictype (ffebld_info (expr));
12884       kt = ffeinfo_kindtype (ffebld_info (expr));
12885
12886       item = ffecom_constantunion (&ffebld_constant_union
12887                                    (ffebld_conter (expr)), bt, kt,
12888                                    ffecom_tree_type[bt][kt]);
12889       if (item == error_mark_node)
12890         return error_mark_node;
12891       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12892                        item);
12893       return item;
12894
12895     case FFEBLD_opANY:
12896       return error_mark_node;
12897
12898     default:
12899       bt = ffeinfo_basictype (ffebld_info (expr));
12900       kt = ffeinfo_kindtype (ffebld_info (expr));
12901
12902       item = ffecom_expr (expr);
12903       if (item == error_mark_node)
12904         return error_mark_node;
12905
12906       /* The back end currently optimizes a bit too zealously for us, in that
12907          we fail JCB001 if the following block of code is omitted.  It checks
12908          to see if the transformed expression is a symbol or array reference,
12909          and encloses it in a SAVE_EXPR if that is the case.  */
12910
12911       STRIP_NOPS (item);
12912       if ((TREE_CODE (item) == VAR_DECL)
12913           || (TREE_CODE (item) == PARM_DECL)
12914           || (TREE_CODE (item) == RESULT_DECL)
12915           || (TREE_CODE (item) == INDIRECT_REF)
12916           || (TREE_CODE (item) == ARRAY_REF)
12917           || (TREE_CODE (item) == COMPONENT_REF)
12918 #ifdef OFFSET_REF
12919           || (TREE_CODE (item) == OFFSET_REF)
12920 #endif
12921           || (TREE_CODE (item) == BUFFER_REF)
12922           || (TREE_CODE (item) == REALPART_EXPR)
12923           || (TREE_CODE (item) == IMAGPART_EXPR))
12924         {
12925           item = ffecom_save_tree (item);
12926         }
12927
12928       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12929                        item);
12930       return item;
12931     }
12932
12933   assert ("fall-through error" == NULL);
12934   return error_mark_node;
12935 }
12936
12937 #endif
12938 /* Obtain a temp var with given data type.
12939
12940    size is FFETARGET_charactersizeNONE for a non-CHARACTER type
12941    or >= 0 for a CHARACTER type.
12942
12943    elements is -1 for a scalar or > 0 for an array of type.  */
12944
12945 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12946 tree
12947 ffecom_make_tempvar (const char *commentary, tree type,
12948                      ffetargetCharacterSize size, int elements)
12949 {
12950   int yes;
12951   tree t;
12952   static int mynumber;
12953
12954   assert (current_binding_level->prep_state < 2);
12955
12956   if (type == error_mark_node)
12957     return error_mark_node;
12958
12959   yes = suspend_momentary ();
12960
12961   if (size != FFETARGET_charactersizeNONE)
12962     type = build_array_type (type,
12963                              build_range_type (ffecom_f2c_ftnlen_type_node,
12964                                                ffecom_f2c_ftnlen_one_node,
12965                                                build_int_2 (size, 0)));
12966   if (elements != -1)
12967     type = build_array_type (type,
12968                              build_range_type (integer_type_node,
12969                                                integer_zero_node,
12970                                                build_int_2 (elements - 1,
12971                                                             0)));
12972   t = build_decl (VAR_DECL,
12973                   ffecom_get_invented_identifier ("__g77_%s_%d",
12974                                                   commentary,
12975                                                   mynumber++),
12976                   type);
12977
12978   t = start_decl (t, FALSE);
12979   finish_decl (t, NULL_TREE, FALSE);
12980
12981   resume_momentary (yes);
12982
12983   return t;
12984 }
12985 #endif
12986
12987 /* Prepare argument pointer to expression.
12988
12989    Like ffecom_prepare_expr, except for expressions to be evaluated
12990    via ffecom_arg_ptr_to_expr.  */
12991
12992 void
12993 ffecom_prepare_arg_ptr_to_expr (ffebld expr)
12994 {
12995   /* ~~For now, it seems to be the same thing.  */
12996   ffecom_prepare_expr (expr);
12997   return;
12998 }
12999
13000 /* End of preparations.  */
13001
13002 bool
13003 ffecom_prepare_end (void)
13004 {
13005   int prep_state = current_binding_level->prep_state;
13006
13007   assert (prep_state < 2);
13008   current_binding_level->prep_state = 2;
13009
13010   return (prep_state == 1) ? TRUE : FALSE;
13011 }
13012
13013 /* Prepare expression.
13014
13015    This is called before any code is generated for the current block.
13016    It scans the expression, declares any temporaries that might be needed
13017    during evaluation of the expression, and stores those temporaries in
13018    the appropriate "hook" fields of the expression.  `dest', if not NULL,
13019    specifies the destination that ffecom_expr_ will see, in case that
13020    helps avoid generating unused temporaries.
13021
13022    ~~Improve to avoid allocating unused temporaries by taking `dest'
13023    into account vis-a-vis aliasing requirements of complex/character
13024    functions.  */
13025
13026 void
13027 ffecom_prepare_expr_ (ffebld expr, ffebld dest UNUSED)
13028 {
13029   ffeinfoBasictype bt;
13030   ffeinfoKindtype kt;
13031   ffetargetCharacterSize sz;
13032   tree tempvar = NULL_TREE;
13033
13034   assert (current_binding_level->prep_state < 2);
13035
13036   if (! expr)
13037     return;
13038
13039   bt = ffeinfo_basictype (ffebld_info (expr));
13040   kt = ffeinfo_kindtype (ffebld_info (expr));
13041   sz = ffeinfo_size (ffebld_info (expr));
13042
13043   /* Generate whatever temporaries are needed to represent the result
13044      of the expression.  */
13045
13046   if (bt == FFEINFO_basictypeCHARACTER)
13047     {
13048       while (ffebld_op (expr) == FFEBLD_opPAREN)
13049         expr = ffebld_left (expr);
13050     }
13051
13052   switch (ffebld_op (expr))
13053     {
13054     default:
13055       /* Don't make temps for SYMTER, CONTER, etc.  */
13056       if (ffebld_arity (expr) == 0)
13057         break;
13058
13059       switch (bt)
13060         {
13061         case FFEINFO_basictypeCOMPLEX:
13062           if (ffebld_op (expr) == FFEBLD_opFUNCREF)
13063             {
13064               ffesymbol s;
13065
13066               if (ffebld_op (ffebld_left (expr)) != FFEBLD_opSYMTER)
13067                 break;
13068
13069               s = ffebld_symter (ffebld_left (expr));
13070               if (ffesymbol_where (s) == FFEINFO_whereCONSTANT
13071                   || (ffesymbol_where (s) != FFEINFO_whereINTRINSIC
13072                       && ! ffesymbol_is_f2c (s))
13073                   || (ffesymbol_where (s) == FFEINFO_whereINTRINSIC
13074                       && ! ffe_is_f2c_library ()))
13075                 break;
13076             }
13077           else if (ffebld_op (expr) == FFEBLD_opPOWER)
13078             {
13079               /* Requires special treatment.  There's no POW_CC function
13080                  in libg2c, so POW_ZZ is used, which means we always
13081                  need a double-complex temp, not a single-complex.  */
13082               kt = FFEINFO_kindtypeREAL2;
13083             }
13084           else if (ffebld_op (expr) != FFEBLD_opDIVIDE)
13085             /* The other ops don't need temps for complex operands.  */
13086             break;
13087
13088           /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
13089              REAL(C).  See 19990325-0.f, routine `check', for cases.  */
13090           tempvar = ffecom_make_tempvar ("complex",
13091                                          ffecom_tree_type
13092                                          [FFEINFO_basictypeCOMPLEX][kt],
13093                                          FFETARGET_charactersizeNONE,
13094                                          -1);
13095           break;
13096
13097         case FFEINFO_basictypeCHARACTER:
13098           if (ffebld_op (expr) != FFEBLD_opFUNCREF)
13099             break;
13100
13101           if (sz == FFETARGET_charactersizeNONE)
13102             /* ~~Kludge alert!  This should someday be fixed. */
13103             sz = 24;
13104
13105           tempvar = ffecom_make_tempvar ("char", char_type_node, sz, -1);
13106           break;
13107
13108         default:
13109           break;
13110         }
13111       break;
13112
13113 #ifdef HAHA
13114     case FFEBLD_opPOWER:
13115       {
13116         tree rtype, ltype;
13117         tree rtmp, ltmp, result;
13118
13119         ltype = ffecom_type_expr (ffebld_left (expr));
13120         rtype = ffecom_type_expr (ffebld_right (expr));
13121
13122         rtmp = ffecom_make_tempvar (rtype, FFETARGET_charactersizeNONE, -1);
13123         ltmp = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
13124         result = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
13125
13126         tempvar = make_tree_vec (3);
13127         TREE_VEC_ELT (tempvar, 0) = rtmp;
13128         TREE_VEC_ELT (tempvar, 1) = ltmp;
13129         TREE_VEC_ELT (tempvar, 2) = result;
13130       }
13131       break;
13132 #endif  /* HAHA */
13133
13134     case FFEBLD_opCONCATENATE:
13135       {
13136         /* This gets special handling, because only one set of temps
13137            is needed for a tree of these -- the tree is treated as
13138            a flattened list of concatenations when generating code.  */
13139
13140         ffecomConcatList_ catlist;
13141         tree ltmp, itmp, result;
13142         int count;
13143         int i;
13144
13145         catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
13146         count = ffecom_concat_list_count_ (catlist);
13147
13148         if (count >= 2)
13149           {
13150             ltmp
13151               = ffecom_make_tempvar ("concat_len",
13152                                      ffecom_f2c_ftnlen_type_node,
13153                                      FFETARGET_charactersizeNONE, count);
13154             itmp
13155               = ffecom_make_tempvar ("concat_item",
13156                                      ffecom_f2c_address_type_node,
13157                                      FFETARGET_charactersizeNONE, count);
13158             result
13159               = ffecom_make_tempvar ("concat_res",
13160                                      char_type_node,
13161                                      ffecom_concat_list_maxlen_ (catlist),
13162                                      -1);
13163
13164             tempvar = make_tree_vec (3);
13165             TREE_VEC_ELT (tempvar, 0) = ltmp;
13166             TREE_VEC_ELT (tempvar, 1) = itmp;
13167             TREE_VEC_ELT (tempvar, 2) = result;
13168           }
13169
13170         for (i = 0; i < count; ++i)
13171           ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist,
13172                                                                     i));
13173
13174         ffecom_concat_list_kill_ (catlist);
13175
13176         if (tempvar)
13177           {
13178             ffebld_nonter_set_hook (expr, tempvar);
13179             current_binding_level->prep_state = 1;
13180           }
13181       }
13182       return;
13183
13184     case FFEBLD_opCONVERT:
13185       if (bt == FFEINFO_basictypeCHARACTER
13186           && ((ffebld_size_known (ffebld_left (expr))
13187                == FFETARGET_charactersizeNONE)
13188               || (ffebld_size_known (ffebld_left (expr)) >= sz)))
13189         tempvar = ffecom_make_tempvar ("convert", char_type_node, sz, -1);
13190       break;
13191     }
13192
13193   if (tempvar)
13194     {
13195       ffebld_nonter_set_hook (expr, tempvar);
13196       current_binding_level->prep_state = 1;
13197     }
13198
13199   /* Prepare subexpressions for this expr.  */
13200
13201   switch (ffebld_op (expr))
13202     {
13203     case FFEBLD_opPERCENT_LOC:
13204       ffecom_prepare_ptr_to_expr (ffebld_left (expr));
13205       break;
13206
13207     case FFEBLD_opPERCENT_VAL:
13208     case FFEBLD_opPERCENT_REF:
13209       ffecom_prepare_expr (ffebld_left (expr));
13210       break;
13211
13212     case FFEBLD_opPERCENT_DESCR:
13213       ffecom_prepare_arg_ptr_to_expr (ffebld_left (expr));
13214       break;
13215
13216     case FFEBLD_opITEM:
13217       {
13218         ffebld item;
13219
13220         for (item = expr;
13221              item != NULL;
13222              item = ffebld_trail (item))
13223           if (ffebld_head (item) != NULL)
13224             ffecom_prepare_expr (ffebld_head (item));
13225       }
13226       break;
13227
13228     default:
13229       /* Need to handle character conversion specially.  */
13230       switch (ffebld_arity (expr))
13231         {
13232         case 2:
13233           ffecom_prepare_expr (ffebld_left (expr));
13234           ffecom_prepare_expr (ffebld_right (expr));
13235           break;
13236
13237         case 1:
13238           ffecom_prepare_expr (ffebld_left (expr));
13239           break;
13240
13241         default:
13242           break;
13243         }
13244     }
13245
13246   return;
13247 }
13248
13249 /* Prepare expression for reading and writing.
13250
13251    Like ffecom_prepare_expr, except for expressions to be evaluated
13252    via ffecom_expr_rw.  */
13253
13254 void
13255 ffecom_prepare_expr_rw (tree type, ffebld expr)
13256 {
13257   /* This is all we support for now.  */
13258   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
13259
13260   /* ~~For now, it seems to be the same thing.  */
13261   ffecom_prepare_expr (expr);
13262   return;
13263 }
13264
13265 /* Prepare expression for writing.
13266
13267    Like ffecom_prepare_expr, except for expressions to be evaluated
13268    via ffecom_expr_w.  */
13269
13270 void
13271 ffecom_prepare_expr_w (tree type, ffebld expr)
13272 {
13273   /* This is all we support for now.  */
13274   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
13275
13276   /* ~~For now, it seems to be the same thing.  */
13277   ffecom_prepare_expr (expr);
13278   return;
13279 }
13280
13281 /* Prepare expression for returning.
13282
13283    Like ffecom_prepare_expr, except for expressions to be evaluated
13284    via ffecom_return_expr.  */
13285
13286 void
13287 ffecom_prepare_return_expr (ffebld expr)
13288 {
13289   assert (current_binding_level->prep_state < 2);
13290
13291   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE
13292       && ffecom_is_altreturning_
13293       && expr != NULL)
13294     ffecom_prepare_expr (expr);
13295 }
13296
13297 /* Prepare pointer to expression.
13298
13299    Like ffecom_prepare_expr, except for expressions to be evaluated
13300    via ffecom_ptr_to_expr.  */
13301
13302 void
13303 ffecom_prepare_ptr_to_expr (ffebld expr)
13304 {
13305   /* ~~For now, it seems to be the same thing.  */
13306   ffecom_prepare_expr (expr);
13307   return;
13308 }
13309
13310 /* Transform expression into constant pointer-to-expression tree.
13311
13312    If the expression can be transformed into a pointer-to-expression tree
13313    that is constant, that is done, and the tree returned.  Else NULL_TREE
13314    is returned.
13315
13316    That way, a caller can attempt to provide compile-time initialization
13317    of a variable and, if that fails, *then* choose to start a new block
13318    and resort to using temporaries, as appropriate.  */
13319
13320 tree
13321 ffecom_ptr_to_const_expr (ffebld expr)
13322 {
13323   if (! expr)
13324     return integer_zero_node;
13325
13326   if (ffebld_op (expr) == FFEBLD_opANY)
13327     return error_mark_node;
13328
13329   if (ffebld_arity (expr) == 0
13330       && (ffebld_op (expr) != FFEBLD_opSYMTER
13331           || ffebld_where (expr) == FFEINFO_whereCOMMON
13332           || ffebld_where (expr) == FFEINFO_whereGLOBAL
13333           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
13334     {
13335       tree t;
13336
13337       t = ffecom_ptr_to_expr (expr);
13338       assert (TREE_CONSTANT (t));
13339       return t;
13340     }
13341
13342   return NULL_TREE;
13343 }
13344
13345 /* ffecom_return_expr -- Returns return-value expr given alt return expr
13346
13347    tree rtn;  // NULL_TREE means use expand_null_return()
13348    ffebld expr;  // NULL if no alt return expr to RETURN stmt
13349    rtn = ffecom_return_expr(expr);
13350
13351    Based on the program unit type and other info (like return function
13352    type, return master function type when alternate ENTRY points,
13353    whether subroutine has any alternate RETURN points, etc), returns the
13354    appropriate expression to be returned to the caller, or NULL_TREE
13355    meaning no return value or the caller expects it to be returned somewhere
13356    else (which is handled by other parts of this module).  */
13357
13358 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13359 tree
13360 ffecom_return_expr (ffebld expr)
13361 {
13362   tree rtn;
13363
13364   switch (ffecom_primary_entry_kind_)
13365     {
13366     case FFEINFO_kindPROGRAM:
13367     case FFEINFO_kindBLOCKDATA:
13368       rtn = NULL_TREE;
13369       break;
13370
13371     case FFEINFO_kindSUBROUTINE:
13372       if (!ffecom_is_altreturning_)
13373         rtn = NULL_TREE;        /* No alt returns, never an expr. */
13374       else if (expr == NULL)
13375         rtn = integer_zero_node;
13376       else
13377         rtn = ffecom_expr (expr);
13378       break;
13379
13380     case FFEINFO_kindFUNCTION:
13381       if ((ffecom_multi_retval_ != NULL_TREE)
13382           || (ffesymbol_basictype (ffecom_primary_entry_)
13383               == FFEINFO_basictypeCHARACTER)
13384           || ((ffesymbol_basictype (ffecom_primary_entry_)
13385                == FFEINFO_basictypeCOMPLEX)
13386               && (ffecom_num_entrypoints_ == 0)
13387               && ffesymbol_is_f2c (ffecom_primary_entry_)))
13388         {                       /* Value is returned by direct assignment
13389                                    into (implicit) dummy. */
13390           rtn = NULL_TREE;
13391           break;
13392         }
13393       rtn = ffecom_func_result_;
13394 #if 0
13395       /* Spurious error if RETURN happens before first reference!  So elide
13396          this code.  In particular, for debugging registry, rtn should always
13397          be non-null after all, but TREE_USED won't be set until we encounter
13398          a reference in the code.  Perfectly okay (but weird) code that,
13399          e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
13400          this diagnostic for no reason.  Have people use -O -Wuninitialized
13401          and leave it to the back end to find obviously weird cases.  */
13402
13403       /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
13404          situation; if the return value has never been referenced, it won't
13405          have a tree under 2pass mode. */
13406       if ((rtn == NULL_TREE)
13407           || !TREE_USED (rtn))
13408         {
13409           ffebad_start (FFEBAD_RETURN_VALUE_UNSET);
13410           ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_),
13411                        ffesymbol_where_column (ffecom_primary_entry_));
13412           ffebad_string (ffesymbol_text (ffesymbol_funcresult
13413                                          (ffecom_primary_entry_)));
13414           ffebad_finish ();
13415         }
13416 #endif
13417       break;
13418
13419     default:
13420       assert ("bad unit kind" == NULL);
13421     case FFEINFO_kindANY:
13422       rtn = error_mark_node;
13423       break;
13424     }
13425
13426   return rtn;
13427 }
13428
13429 #endif
13430 /* Do save_expr only if tree is not error_mark_node.  */
13431
13432 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13433 tree
13434 ffecom_save_tree (tree t)
13435 {
13436   return save_expr (t);
13437 }
13438 #endif
13439
13440 /* Start a compound statement (block).  */
13441
13442 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13443 void
13444 ffecom_start_compstmt (void)
13445 {
13446   bison_rule_pushlevel_ ();
13447 }
13448 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
13449
13450 /* Public entry point for front end to access start_decl.  */
13451
13452 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13453 tree
13454 ffecom_start_decl (tree decl, bool is_initialized)
13455 {
13456   DECL_INITIAL (decl) = is_initialized ? error_mark_node : NULL_TREE;
13457   return start_decl (decl, FALSE);
13458 }
13459
13460 #endif
13461 /* ffecom_sym_commit -- Symbol's state being committed to reality
13462
13463    ffesymbol s;
13464    ffecom_sym_commit(s);
13465
13466    Does whatever the backend needs when a symbol is committed after having
13467    been backtrackable for a period of time.  */
13468
13469 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13470 void
13471 ffecom_sym_commit (ffesymbol s UNUSED)
13472 {
13473   assert (!ffesymbol_retractable ());
13474 }
13475
13476 #endif
13477 /* ffecom_sym_end_transition -- Perform end transition on all symbols
13478
13479    ffecom_sym_end_transition();
13480
13481    Does backend-specific stuff and also calls ffest_sym_end_transition
13482    to do the necessary FFE stuff.
13483
13484    Backtracking is never enabled when this fn is called, so don't worry
13485    about it.  */
13486
13487 ffesymbol
13488 ffecom_sym_end_transition (ffesymbol s)
13489 {
13490   ffestorag st;
13491
13492   assert (!ffesymbol_retractable ());
13493
13494   s = ffest_sym_end_transition (s);
13495
13496 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13497   if ((ffesymbol_kind (s) == FFEINFO_kindBLOCKDATA)
13498       && (ffesymbol_where (s) == FFEINFO_whereGLOBAL))
13499     {
13500       ffecom_list_blockdata_
13501         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
13502                                               FFEINTRIN_specNONE,
13503                                               FFEINTRIN_impNONE),
13504                            ffecom_list_blockdata_);
13505     }
13506 #endif
13507
13508   /* This is where we finally notice that a symbol has partial initialization
13509      and finalize it. */
13510
13511   if (ffesymbol_accretion (s) != NULL)
13512     {
13513       assert (ffesymbol_init (s) == NULL);
13514       ffecom_notify_init_symbol (s);
13515     }
13516   else if (((st = ffesymbol_storage (s)) != NULL)
13517            && ((st = ffestorag_parent (st)) != NULL)
13518            && (ffestorag_accretion (st) != NULL))
13519     {
13520       assert (ffestorag_init (st) == NULL);
13521       ffecom_notify_init_storage (st);
13522     }
13523
13524 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13525   if ((ffesymbol_kind (s) == FFEINFO_kindCOMMON)
13526       && (ffesymbol_where (s) == FFEINFO_whereLOCAL)
13527       && (ffesymbol_storage (s) != NULL))
13528     {
13529       ffecom_list_common_
13530         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
13531                                               FFEINTRIN_specNONE,
13532                                               FFEINTRIN_impNONE),
13533                            ffecom_list_common_);
13534     }
13535 #endif
13536
13537   return s;
13538 }
13539
13540 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
13541
13542    ffecom_sym_exec_transition();
13543
13544    Does backend-specific stuff and also calls ffest_sym_exec_transition
13545    to do the necessary FFE stuff.
13546
13547    See the long-winded description in ffecom_sym_learned for info
13548    on handling the situation where backtracking is inhibited.  */
13549
13550 ffesymbol
13551 ffecom_sym_exec_transition (ffesymbol s)
13552 {
13553   s = ffest_sym_exec_transition (s);
13554
13555   return s;
13556 }
13557
13558 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
13559
13560    ffesymbol s;
13561    s = ffecom_sym_learned(s);
13562
13563    Called when a new symbol is seen after the exec transition or when more
13564    info (perhaps) is gained for an UNCERTAIN symbol.  The symbol state when
13565    it arrives here is that all its latest info is updated already, so its
13566    state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
13567    field filled in if its gone through here or exec_transition first, and
13568    so on.
13569
13570    The backend probably wants to check ffesymbol_retractable() to see if
13571    backtracking is in effect.  If so, the FFE's changes to the symbol may
13572    be retracted (undone) or committed (ratified), at which time the
13573    appropriate ffecom_sym_retract or _commit function will be called
13574    for that function.
13575
13576    If the backend has its own backtracking mechanism, great, use it so that
13577    committal is a simple operation.  Though it doesn't make much difference,
13578    I suppose: the reason for tentative symbol evolution in the FFE is to
13579    enable error detection in weird incorrect statements early and to disable
13580    incorrect error detection on a correct statement.  The backend is not
13581    likely to introduce any information that'll get involved in these
13582    considerations, so it is probably just fine that the implementation
13583    model for this fn and for _exec_transition is to not do anything
13584    (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
13585    and instead wait until ffecom_sym_commit is called (which it never
13586    will be as long as we're using ambiguity-detecting statement analysis in
13587    the FFE, which we are initially to shake out the code, but don't depend
13588    on this), otherwise go ahead and do whatever is needed.
13589
13590    In essence, then, when this fn and _exec_transition get called while
13591    backtracking is enabled, a general mechanism would be to flag which (or
13592    both) of these were called (and in what order? neat question as to what
13593    might happen that I'm too lame to think through right now) and then when
13594    _commit is called reproduce the original calling sequence, if any, for
13595    the two fns (at which point backtracking will, of course, be disabled).  */
13596
13597 ffesymbol
13598 ffecom_sym_learned (ffesymbol s)
13599 {
13600   ffestorag_exec_layout (s);
13601
13602   return s;
13603 }
13604
13605 /* ffecom_sym_retract -- Symbol's state being retracted from reality
13606
13607    ffesymbol s;
13608    ffecom_sym_retract(s);
13609
13610    Does whatever the backend needs when a symbol is retracted after having
13611    been backtrackable for a period of time.  */
13612
13613 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13614 void
13615 ffecom_sym_retract (ffesymbol s UNUSED)
13616 {
13617   assert (!ffesymbol_retractable ());
13618
13619 #if 0                           /* GCC doesn't commit any backtrackable sins,
13620                                    so nothing needed here. */
13621   switch (ffesymbol_hook (s).state)
13622     {
13623     case 0:                     /* nothing happened yet. */
13624       break;
13625
13626     case 1:                     /* exec transition happened. */
13627       break;
13628
13629     case 2:                     /* learned happened. */
13630       break;
13631
13632     case 3:                     /* learned then exec. */
13633       break;
13634
13635     case 4:                     /* exec then learned. */
13636       break;
13637
13638     default:
13639       assert ("bad hook state" == NULL);
13640       break;
13641     }
13642 #endif
13643 }
13644
13645 #endif
13646 /* Create temporary gcc label.  */
13647
13648 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13649 tree
13650 ffecom_temp_label ()
13651 {
13652   tree glabel;
13653   static int mynumber = 0;
13654
13655   glabel = build_decl (LABEL_DECL,
13656                        ffecom_get_invented_identifier ("__g77_label_%d",
13657                                                        NULL,
13658                                                        mynumber++),
13659                        void_type_node);
13660   DECL_CONTEXT (glabel) = current_function_decl;
13661   DECL_MODE (glabel) = VOIDmode;
13662
13663   return glabel;
13664 }
13665
13666 #endif
13667 /* Return an expression that is usable as an arg in a conditional context
13668    (IF, DO WHILE, .NOT., and so on).
13669
13670    Use the one provided for the back end as of >2.6.0.  */
13671
13672 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13673 tree
13674 ffecom_truth_value (tree expr)
13675 {
13676   return truthvalue_conversion (expr);
13677 }
13678
13679 #endif
13680 /* Return the inversion of a truth value (the inversion of what
13681    ffecom_truth_value builds).
13682
13683    Apparently invert_truthvalue, which is properly in the back end, is
13684    enough for now, so just use it.  */
13685
13686 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13687 tree
13688 ffecom_truth_value_invert (tree expr)
13689 {
13690   return invert_truthvalue (ffecom_truth_value (expr));
13691 }
13692
13693 #endif
13694
13695 /* Return the tree that is the type of the expression, as would be
13696    returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
13697    transforming the expression, generating temporaries, etc.  */
13698
13699 tree
13700 ffecom_type_expr (ffebld expr)
13701 {
13702   ffeinfoBasictype bt;
13703   ffeinfoKindtype kt;
13704   tree tree_type;
13705
13706   assert (expr != NULL);
13707
13708   bt = ffeinfo_basictype (ffebld_info (expr));
13709   kt = ffeinfo_kindtype (ffebld_info (expr));
13710   tree_type = ffecom_tree_type[bt][kt];
13711
13712   switch (ffebld_op (expr))
13713     {
13714     case FFEBLD_opCONTER:
13715     case FFEBLD_opSYMTER:
13716     case FFEBLD_opARRAYREF:
13717     case FFEBLD_opUPLUS:
13718     case FFEBLD_opPAREN:
13719     case FFEBLD_opUMINUS:
13720     case FFEBLD_opADD:
13721     case FFEBLD_opSUBTRACT:
13722     case FFEBLD_opMULTIPLY:
13723     case FFEBLD_opDIVIDE:
13724     case FFEBLD_opPOWER:
13725     case FFEBLD_opNOT:
13726     case FFEBLD_opFUNCREF:
13727     case FFEBLD_opSUBRREF:
13728     case FFEBLD_opAND:
13729     case FFEBLD_opOR:
13730     case FFEBLD_opXOR:
13731     case FFEBLD_opNEQV:
13732     case FFEBLD_opEQV:
13733     case FFEBLD_opCONVERT:
13734     case FFEBLD_opLT:
13735     case FFEBLD_opLE:
13736     case FFEBLD_opEQ:
13737     case FFEBLD_opNE:
13738     case FFEBLD_opGT:
13739     case FFEBLD_opGE:
13740     case FFEBLD_opPERCENT_LOC:
13741       return tree_type;
13742
13743     case FFEBLD_opACCTER:
13744     case FFEBLD_opARRTER:
13745     case FFEBLD_opITEM:
13746     case FFEBLD_opSTAR:
13747     case FFEBLD_opBOUNDS:
13748     case FFEBLD_opREPEAT:
13749     case FFEBLD_opLABTER:
13750     case FFEBLD_opLABTOK:
13751     case FFEBLD_opIMPDO:
13752     case FFEBLD_opCONCATENATE:
13753     case FFEBLD_opSUBSTR:
13754     default:
13755       assert ("bad op for ffecom_type_expr" == NULL);
13756       /* Fall through. */
13757     case FFEBLD_opANY:
13758       return error_mark_node;
13759     }
13760 }
13761
13762 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13763
13764    If the PARM_DECL already exists, return it, else create it.  It's an
13765    integer_type_node argument for the master function that implements a
13766    subroutine or function with more than one entrypoint and is bound at
13767    run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13768    first ENTRY statement, and so on).  */
13769
13770 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13771 tree
13772 ffecom_which_entrypoint_decl ()
13773 {
13774   assert (ffecom_which_entrypoint_decl_ != NULL_TREE);
13775
13776   return ffecom_which_entrypoint_decl_;
13777 }
13778
13779 #endif
13780 \f
13781 /* The following sections consists of private and public functions
13782    that have the same names and perform roughly the same functions
13783    as counterparts in the C front end.  Changes in the C front end
13784    might affect how things should be done here.  Only functions
13785    needed by the back end should be public here; the rest should
13786    be private (static in the C sense).  Functions needed by other
13787    g77 front-end modules should be accessed by them via public
13788    ffecom_* names, which should themselves call private versions
13789    in this section so the private versions are easy to recognize
13790    when upgrading to a new gcc and finding interesting changes
13791    in the front end.
13792
13793    Functions named after rule "foo:" in c-parse.y are named
13794    "bison_rule_foo_" so they are easy to find.  */
13795
13796 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13797
13798 static void
13799 bison_rule_pushlevel_ ()
13800 {
13801   emit_line_note (input_filename, lineno);
13802   pushlevel (0);
13803   clear_last_expr ();
13804   push_momentary ();
13805   expand_start_bindings (0);
13806 }
13807
13808 static tree
13809 bison_rule_compstmt_ ()
13810 {
13811   tree t;
13812   int keep = kept_level_p ();
13813
13814   /* Make the temps go away.  */
13815   if (! keep)
13816     current_binding_level->names = NULL_TREE;
13817
13818   emit_line_note (input_filename, lineno);
13819   expand_end_bindings (getdecls (), keep, 0);
13820   t = poplevel (keep, 1, 0);
13821   pop_momentary ();
13822
13823   return t;
13824 }
13825
13826 /* Return a definition for a builtin function named NAME and whose data type
13827    is TYPE.  TYPE should be a function type with argument types.
13828    FUNCTION_CODE tells later passes how to compile calls to this function.
13829    See tree.h for its possible values.
13830
13831    If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13832    the name to be called if we can't opencode the function.  */
13833
13834 static tree
13835 builtin_function (const char *name, tree type,
13836                   enum built_in_function function_code,
13837                   const char *library_name)
13838 {
13839   tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
13840   DECL_EXTERNAL (decl) = 1;
13841   TREE_PUBLIC (decl) = 1;
13842   if (library_name)
13843     DECL_ASSEMBLER_NAME (decl) = get_identifier (library_name);
13844   make_decl_rtl (decl, NULL_PTR, 1);
13845   pushdecl (decl);
13846   if (function_code != NOT_BUILT_IN)
13847     {
13848       DECL_BUILT_IN (decl) = 1;
13849       DECL_FUNCTION_CODE (decl) = function_code;
13850     }
13851
13852   return decl;
13853 }
13854
13855 /* Handle when a new declaration NEWDECL
13856    has the same name as an old one OLDDECL
13857    in the same binding contour.
13858    Prints an error message if appropriate.
13859
13860    If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13861    Otherwise, return 0.  */
13862
13863 static int
13864 duplicate_decls (tree newdecl, tree olddecl)
13865 {
13866   int types_match = 1;
13867   int new_is_definition = (TREE_CODE (newdecl) == FUNCTION_DECL
13868                            && DECL_INITIAL (newdecl) != 0);
13869   tree oldtype = TREE_TYPE (olddecl);
13870   tree newtype = TREE_TYPE (newdecl);
13871
13872   if (olddecl == newdecl)
13873     return 1;
13874
13875   if (TREE_CODE (newtype) == ERROR_MARK
13876       || TREE_CODE (oldtype) == ERROR_MARK)
13877     types_match = 0;
13878
13879   /* New decl is completely inconsistent with the old one =>
13880      tell caller to replace the old one.
13881      This is always an error except in the case of shadowing a builtin.  */
13882   if (TREE_CODE (olddecl) != TREE_CODE (newdecl))
13883     return 0;
13884
13885   /* For real parm decl following a forward decl,
13886      return 1 so old decl will be reused.  */
13887   if (types_match && TREE_CODE (newdecl) == PARM_DECL
13888       && TREE_ASM_WRITTEN (olddecl) && ! TREE_ASM_WRITTEN (newdecl))
13889     return 1;
13890
13891   /* The new declaration is the same kind of object as the old one.
13892      The declarations may partially match.  Print warnings if they don't
13893      match enough.  Ultimately, copy most of the information from the new
13894      decl to the old one, and keep using the old one.  */
13895
13896   if (TREE_CODE (olddecl) == FUNCTION_DECL
13897       && DECL_BUILT_IN (olddecl))
13898     {
13899       /* A function declaration for a built-in function.  */
13900       if (!TREE_PUBLIC (newdecl))
13901         return 0;
13902       else if (!types_match)
13903         {
13904           /* Accept the return type of the new declaration if same modes.  */
13905           tree oldreturntype = TREE_TYPE (TREE_TYPE (olddecl));
13906           tree newreturntype = TREE_TYPE (TREE_TYPE (newdecl));
13907
13908           /* Make sure we put the new type in the same obstack as the old ones.
13909              If the old types are not both in the same obstack, use the
13910              permanent one.  */
13911           if (TYPE_OBSTACK (oldtype) == TYPE_OBSTACK (newtype))
13912             push_obstacks (TYPE_OBSTACK (oldtype), TYPE_OBSTACK (oldtype));
13913           else
13914             {
13915               push_obstacks_nochange ();
13916               end_temporary_allocation ();
13917             }
13918
13919           if (TYPE_MODE (oldreturntype) == TYPE_MODE (newreturntype))
13920             {
13921               /* Function types may be shared, so we can't just modify
13922                  the return type of olddecl's function type.  */
13923               tree newtype
13924                 = build_function_type (newreturntype,
13925                                        TYPE_ARG_TYPES (TREE_TYPE (olddecl)));
13926
13927               types_match = 1;
13928               if (types_match)
13929                 TREE_TYPE (olddecl) = newtype;
13930             }
13931
13932           pop_obstacks ();
13933         }
13934       if (!types_match)
13935         return 0;
13936     }
13937   else if (TREE_CODE (olddecl) == FUNCTION_DECL
13938            && DECL_SOURCE_LINE (olddecl) == 0)
13939     {
13940       /* A function declaration for a predeclared function
13941          that isn't actually built in.  */
13942       if (!TREE_PUBLIC (newdecl))
13943         return 0;
13944       else if (!types_match)
13945         {
13946           /* If the types don't match, preserve volatility indication.
13947              Later on, we will discard everything else about the
13948              default declaration.  */
13949           TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl);
13950         }
13951     }
13952
13953   /* Copy all the DECL_... slots specified in the new decl
13954      except for any that we copy here from the old type.
13955
13956      Past this point, we don't change OLDTYPE and NEWTYPE
13957      even if we change the types of NEWDECL and OLDDECL.  */
13958
13959   if (types_match)
13960     {
13961       /* Make sure we put the new type in the same obstack as the old ones.
13962          If the old types are not both in the same obstack, use the permanent
13963          one.  */
13964       if (TYPE_OBSTACK (oldtype) == TYPE_OBSTACK (newtype))
13965         push_obstacks (TYPE_OBSTACK (oldtype), TYPE_OBSTACK (oldtype));
13966       else
13967         {
13968           push_obstacks_nochange ();
13969           end_temporary_allocation ();
13970         }
13971
13972       /* Merge the data types specified in the two decls.  */
13973       if (TREE_CODE (newdecl) != FUNCTION_DECL || !DECL_BUILT_IN (olddecl))
13974         TREE_TYPE (newdecl)
13975           = TREE_TYPE (olddecl)
13976             = TREE_TYPE (newdecl);
13977
13978       /* Lay the type out, unless already done.  */
13979       if (oldtype != TREE_TYPE (newdecl))
13980         {
13981           if (TREE_TYPE (newdecl) != error_mark_node)
13982             layout_type (TREE_TYPE (newdecl));
13983           if (TREE_CODE (newdecl) != FUNCTION_DECL
13984               && TREE_CODE (newdecl) != TYPE_DECL
13985               && TREE_CODE (newdecl) != CONST_DECL)
13986             layout_decl (newdecl, 0);
13987         }
13988       else
13989         {
13990           /* Since the type is OLDDECL's, make OLDDECL's size go with.  */
13991           DECL_SIZE (newdecl) = DECL_SIZE (olddecl);
13992           if (TREE_CODE (olddecl) != FUNCTION_DECL)
13993             if (DECL_ALIGN (olddecl) > DECL_ALIGN (newdecl))
13994               DECL_ALIGN (newdecl) = DECL_ALIGN (olddecl);
13995         }
13996
13997       /* Keep the old rtl since we can safely use it.  */
13998       DECL_RTL (newdecl) = DECL_RTL (olddecl);
13999
14000       /* Merge the type qualifiers.  */
14001       if (DECL_BUILT_IN_NONANSI (olddecl) && TREE_THIS_VOLATILE (olddecl)
14002           && !TREE_THIS_VOLATILE (newdecl))
14003         TREE_THIS_VOLATILE (olddecl) = 0;
14004       if (TREE_READONLY (newdecl))
14005         TREE_READONLY (olddecl) = 1;
14006       if (TREE_THIS_VOLATILE (newdecl))
14007         {
14008           TREE_THIS_VOLATILE (olddecl) = 1;
14009           if (TREE_CODE (newdecl) == VAR_DECL)
14010             make_var_volatile (newdecl);
14011         }
14012
14013       /* Keep source location of definition rather than declaration.
14014          Likewise, keep decl at outer scope.  */
14015       if ((DECL_INITIAL (newdecl) == 0 && DECL_INITIAL (olddecl) != 0)
14016           || (DECL_CONTEXT (newdecl) != 0 && DECL_CONTEXT (olddecl) == 0))
14017         {
14018           DECL_SOURCE_LINE (newdecl) = DECL_SOURCE_LINE (olddecl);
14019           DECL_SOURCE_FILE (newdecl) = DECL_SOURCE_FILE (olddecl);
14020
14021           if (DECL_CONTEXT (olddecl) == 0
14022               && TREE_CODE (newdecl) != FUNCTION_DECL)
14023             DECL_CONTEXT (newdecl) = 0;
14024         }
14025
14026       /* Merge the unused-warning information.  */
14027       if (DECL_IN_SYSTEM_HEADER (olddecl))
14028         DECL_IN_SYSTEM_HEADER (newdecl) = 1;
14029       else if (DECL_IN_SYSTEM_HEADER (newdecl))
14030         DECL_IN_SYSTEM_HEADER (olddecl) = 1;
14031
14032       /* Merge the initialization information.  */
14033       if (DECL_INITIAL (newdecl) == 0)
14034         DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
14035
14036       /* Merge the section attribute.
14037          We want to issue an error if the sections conflict but that must be
14038          done later in decl_attributes since we are called before attributes
14039          are assigned.  */
14040       if (DECL_SECTION_NAME (newdecl) == NULL_TREE)
14041         DECL_SECTION_NAME (newdecl) = DECL_SECTION_NAME (olddecl);
14042
14043 #if BUILT_FOR_270
14044       if (TREE_CODE (newdecl) == FUNCTION_DECL)
14045         {
14046           DECL_STATIC_CONSTRUCTOR(newdecl) |= DECL_STATIC_CONSTRUCTOR(olddecl);
14047           DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl);
14048         }
14049 #endif
14050
14051       pop_obstacks ();
14052     }
14053   /* If cannot merge, then use the new type and qualifiers,
14054      and don't preserve the old rtl.  */
14055   else
14056     {
14057       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
14058       TREE_READONLY (olddecl) = TREE_READONLY (newdecl);
14059       TREE_THIS_VOLATILE (olddecl) = TREE_THIS_VOLATILE (newdecl);
14060       TREE_SIDE_EFFECTS (olddecl) = TREE_SIDE_EFFECTS (newdecl);
14061     }
14062
14063   /* Merge the storage class information.  */
14064   /* For functions, static overrides non-static.  */
14065   if (TREE_CODE (newdecl) == FUNCTION_DECL)
14066     {
14067       TREE_PUBLIC (newdecl) &= TREE_PUBLIC (olddecl);
14068       /* This is since we don't automatically
14069          copy the attributes of NEWDECL into OLDDECL.  */
14070       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
14071       /* If this clears `static', clear it in the identifier too.  */
14072       if (! TREE_PUBLIC (olddecl))
14073         TREE_PUBLIC (DECL_NAME (olddecl)) = 0;
14074     }
14075   if (DECL_EXTERNAL (newdecl))
14076     {
14077       TREE_STATIC (newdecl) = TREE_STATIC (olddecl);
14078       DECL_EXTERNAL (newdecl) = DECL_EXTERNAL (olddecl);
14079       /* An extern decl does not override previous storage class.  */
14080       TREE_PUBLIC (newdecl) = TREE_PUBLIC (olddecl);
14081     }
14082   else
14083     {
14084       TREE_STATIC (olddecl) = TREE_STATIC (newdecl);
14085       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
14086     }
14087
14088   /* If either decl says `inline', this fn is inline,
14089      unless its definition was passed already.  */
14090   if (DECL_INLINE (newdecl) && DECL_INITIAL (olddecl) == 0)
14091     DECL_INLINE (olddecl) = 1;
14092   DECL_INLINE (newdecl) = DECL_INLINE (olddecl);
14093
14094   /* Get rid of any built-in function if new arg types don't match it
14095      or if we have a function definition.  */
14096   if (TREE_CODE (newdecl) == FUNCTION_DECL
14097       && DECL_BUILT_IN (olddecl)
14098       && (!types_match || new_is_definition))
14099     {
14100       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
14101       DECL_BUILT_IN (olddecl) = 0;
14102     }
14103
14104   /* If redeclaring a builtin function, and not a definition,
14105      it stays built in.
14106      Also preserve various other info from the definition.  */
14107   if (TREE_CODE (newdecl) == FUNCTION_DECL && !new_is_definition)
14108     {
14109       if (DECL_BUILT_IN (olddecl))
14110         {
14111           DECL_BUILT_IN (newdecl) = 1;
14112           DECL_FUNCTION_CODE (newdecl) = DECL_FUNCTION_CODE (olddecl);
14113         }
14114       else
14115         DECL_FRAME_SIZE (newdecl) = DECL_FRAME_SIZE (olddecl);
14116
14117       DECL_RESULT (newdecl) = DECL_RESULT (olddecl);
14118       DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
14119       DECL_SAVED_INSNS (newdecl) = DECL_SAVED_INSNS (olddecl);
14120       DECL_ARGUMENTS (newdecl) = DECL_ARGUMENTS (olddecl);
14121     }
14122
14123   /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
14124      But preserve olddecl's DECL_UID.  */
14125   {
14126     register unsigned olddecl_uid = DECL_UID (olddecl);
14127
14128     memcpy ((char *) olddecl + sizeof (struct tree_common),
14129             (char *) newdecl + sizeof (struct tree_common),
14130             sizeof (struct tree_decl) - sizeof (struct tree_common));
14131     DECL_UID (olddecl) = olddecl_uid;
14132   }
14133
14134   return 1;
14135 }
14136
14137 /* Finish processing of a declaration;
14138    install its initial value.
14139    If the length of an array type is not known before,
14140    it must be determined now, from the initial value, or it is an error.  */
14141
14142 static void
14143 finish_decl (tree decl, tree init, bool is_top_level)
14144 {
14145   register tree type = TREE_TYPE (decl);
14146   int was_incomplete = (DECL_SIZE (decl) == 0);
14147   int temporary = allocation_temporary_p ();
14148   bool at_top_level = (current_binding_level == global_binding_level);
14149   bool top_level = is_top_level || at_top_level;
14150
14151   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
14152      level anyway.  */
14153   assert (!is_top_level || !at_top_level);
14154
14155   if (TREE_CODE (decl) == PARM_DECL)
14156     assert (init == NULL_TREE);
14157   /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
14158      overlaps DECL_ARG_TYPE.  */
14159   else if (init == NULL_TREE)
14160     assert (DECL_INITIAL (decl) == NULL_TREE);
14161   else
14162     assert (DECL_INITIAL (decl) == error_mark_node);
14163
14164   if (init != NULL_TREE)
14165     {
14166       if (TREE_CODE (decl) != TYPE_DECL)
14167         DECL_INITIAL (decl) = init;
14168       else
14169         {
14170           /* typedef foo = bar; store the type of bar as the type of foo.  */
14171           TREE_TYPE (decl) = TREE_TYPE (init);
14172           DECL_INITIAL (decl) = init = 0;
14173         }
14174     }
14175
14176   /* Pop back to the obstack that is current for this binding level. This is
14177      because MAXINDEX, rtl, etc. to be made below must go in the permanent
14178      obstack.  But don't discard the temporary data yet.  */
14179   pop_obstacks ();
14180
14181   /* Deduce size of array from initialization, if not already known */
14182
14183   if (TREE_CODE (type) == ARRAY_TYPE
14184       && TYPE_DOMAIN (type) == 0
14185       && TREE_CODE (decl) != TYPE_DECL)
14186     {
14187       assert (top_level);
14188       assert (was_incomplete);
14189
14190       layout_decl (decl, 0);
14191     }
14192
14193   if (TREE_CODE (decl) == VAR_DECL)
14194     {
14195       if (DECL_SIZE (decl) == NULL_TREE
14196           && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
14197         layout_decl (decl, 0);
14198
14199       if (DECL_SIZE (decl) == NULL_TREE
14200           && (TREE_STATIC (decl)
14201               ?
14202       /* A static variable with an incomplete type is an error if it is
14203          initialized. Also if it is not file scope. Otherwise, let it
14204          through, but if it is not `extern' then it may cause an error
14205          message later.  */
14206               (DECL_INITIAL (decl) != 0 || DECL_CONTEXT (decl) != 0)
14207               :
14208       /* An automatic variable with an incomplete type is an error.  */
14209               !DECL_EXTERNAL (decl)))
14210         {
14211           assert ("storage size not known" == NULL);
14212           abort ();
14213         }
14214
14215       if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
14216           && (DECL_SIZE (decl) != 0)
14217           && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
14218         {
14219           assert ("storage size not constant" == NULL);
14220           abort ();
14221         }
14222     }
14223
14224   /* Output the assembler code and/or RTL code for variables and functions,
14225      unless the type is an undefined structure or union. If not, it will get
14226      done when the type is completed.  */
14227
14228   if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL)
14229     {
14230       rest_of_decl_compilation (decl, NULL,
14231                                 DECL_CONTEXT (decl) == 0,
14232                                 0);
14233
14234       if (DECL_CONTEXT (decl) != 0)
14235         {
14236           /* Recompute the RTL of a local array now if it used to be an
14237              incomplete type.  */
14238           if (was_incomplete
14239               && !TREE_STATIC (decl) && !DECL_EXTERNAL (decl))
14240             {
14241               /* If we used it already as memory, it must stay in memory.  */
14242               TREE_ADDRESSABLE (decl) = TREE_USED (decl);
14243               /* If it's still incomplete now, no init will save it.  */
14244               if (DECL_SIZE (decl) == 0)
14245                 DECL_INITIAL (decl) = 0;
14246               expand_decl (decl);
14247             }
14248           /* Compute and store the initial value.  */
14249           if (TREE_CODE (decl) != FUNCTION_DECL)
14250             expand_decl_init (decl);
14251         }
14252     }
14253   else if (TREE_CODE (decl) == TYPE_DECL)
14254     {
14255       rest_of_decl_compilation (decl, NULL_PTR,
14256                                 DECL_CONTEXT (decl) == 0,
14257                                 0);
14258     }
14259
14260   /* This test used to include TREE_PERMANENT, however, we have the same
14261      problem with initializers at the function level.  Such initializers get
14262      saved until the end of the function on the momentary_obstack.  */
14263   if (!(TREE_CODE (decl) == FUNCTION_DECL && DECL_INLINE (decl))
14264       && temporary
14265   /* DECL_INITIAL is not defined in PARM_DECLs, since it shares space with
14266      DECL_ARG_TYPE.  */
14267       && TREE_CODE (decl) != PARM_DECL)
14268     {
14269       /* We need to remember that this array HAD an initialization, but
14270          discard the actual temporary nodes, since we can't have a permanent
14271          node keep pointing to them.  */
14272       /* We make an exception for inline functions, since it's normal for a
14273          local extern redeclaration of an inline function to have a copy of
14274          the top-level decl's DECL_INLINE.  */
14275       if ((DECL_INITIAL (decl) != 0)
14276           && (DECL_INITIAL (decl) != error_mark_node))
14277         {
14278           /* If this is a const variable, then preserve the
14279              initializer instead of discarding it so that we can optimize
14280              references to it.  */
14281           /* This test used to include TREE_STATIC, but this won't be set
14282              for function level initializers.  */
14283           if (TREE_READONLY (decl))
14284             {
14285               preserve_initializer ();
14286               /* Hack?  Set the permanent bit for something that is
14287                  permanent, but not on the permenent obstack, so as to
14288                  convince output_constant_def to make its rtl on the
14289                  permanent obstack.  */
14290               TREE_PERMANENT (DECL_INITIAL (decl)) = 1;
14291
14292               /* The initializer and DECL must have the same (or equivalent
14293                  types), but if the initializer is a STRING_CST, its type
14294                  might not be on the right obstack, so copy the type
14295                  of DECL.  */
14296               TREE_TYPE (DECL_INITIAL (decl)) = type;
14297             }
14298           else
14299             DECL_INITIAL (decl) = error_mark_node;
14300         }
14301     }
14302
14303   /* If requested, warn about definitions of large data objects.  */
14304
14305   if (warn_larger_than
14306       && (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == PARM_DECL)
14307       && !DECL_EXTERNAL (decl))
14308     {
14309       register tree decl_size = DECL_SIZE (decl);
14310
14311       if (decl_size && TREE_CODE (decl_size) == INTEGER_CST)
14312         {
14313            unsigned units = TREE_INT_CST_LOW (decl_size) / BITS_PER_UNIT;
14314
14315           if (units > larger_than_size)
14316             warning_with_decl (decl, "size of `%s' is %u bytes", units);
14317         }
14318     }
14319
14320   /* If we have gone back from temporary to permanent allocation, actually
14321      free the temporary space that we no longer need.  */
14322   if (temporary && !allocation_temporary_p ())
14323     permanent_allocation (0);
14324
14325   /* At the end of a declaration, throw away any variable type sizes of types
14326      defined inside that declaration.  There is no use computing them in the
14327      following function definition.  */
14328   if (current_binding_level == global_binding_level)
14329     get_pending_sizes ();
14330 }
14331
14332 /* Finish up a function declaration and compile that function
14333    all the way to assembler language output.  The free the storage
14334    for the function definition.
14335
14336    This is called after parsing the body of the function definition.
14337
14338    NESTED is nonzero if the function being finished is nested in another.  */
14339
14340 static void
14341 finish_function (int nested)
14342 {
14343   register tree fndecl = current_function_decl;
14344
14345   assert (fndecl != NULL_TREE);
14346   if (TREE_CODE (fndecl) != ERROR_MARK)
14347     {
14348       if (nested)
14349         assert (DECL_CONTEXT (fndecl) != NULL_TREE);
14350       else
14351         assert (DECL_CONTEXT (fndecl) == NULL_TREE);
14352     }
14353
14354 /*  TREE_READONLY (fndecl) = 1;
14355     This caused &foo to be of type ptr-to-const-function
14356     which then got a warning when stored in a ptr-to-function variable.  */
14357
14358   poplevel (1, 0, 1);
14359
14360   if (TREE_CODE (fndecl) != ERROR_MARK)
14361     {
14362       BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
14363
14364       /* Must mark the RESULT_DECL as being in this function.  */
14365
14366       DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
14367
14368       /* Obey `register' declarations if `setjmp' is called in this fn.  */
14369       /* Generate rtl for function exit.  */
14370       expand_function_end (input_filename, lineno, 0);
14371
14372       /* So we can tell if jump_optimize sets it to 1.  */
14373       can_reach_end = 0;
14374
14375       /* Run the optimizers and output the assembler code for this function.  */
14376       rest_of_compilation (fndecl);
14377     }
14378
14379   /* Free all the tree nodes making up this function.  */
14380   /* Switch back to allocating nodes permanently until we start another
14381      function.  */
14382   if (!nested)
14383     permanent_allocation (1);
14384
14385   if (TREE_CODE (fndecl) != ERROR_MARK
14386       && !nested
14387       && DECL_SAVED_INSNS (fndecl) == 0)
14388     {
14389       /* Stop pointing to the local nodes about to be freed.  */
14390       /* But DECL_INITIAL must remain nonzero so we know this was an actual
14391          function definition.  */
14392       /* For a nested function, this is done in pop_f_function_context.  */
14393       /* If rest_of_compilation set this to 0, leave it 0.  */
14394       if (DECL_INITIAL (fndecl) != 0)
14395         DECL_INITIAL (fndecl) = error_mark_node;
14396       DECL_ARGUMENTS (fndecl) = 0;
14397     }
14398
14399   if (!nested)
14400     {
14401       /* Let the error reporting routines know that we're outside a function.
14402          For a nested function, this value is used in pop_c_function_context
14403          and then reset via pop_function_context.  */
14404       ffecom_outer_function_decl_ = current_function_decl = NULL;
14405     }
14406 }
14407
14408 /* Plug-in replacement for identifying the name of a decl and, for a
14409    function, what we call it in diagnostics.  For now, "program unit"
14410    should suffice, since it's a bit of a hassle to figure out which
14411    of several kinds of things it is.  Note that it could conceivably
14412    be a statement function, which probably isn't really a program unit
14413    per se, but if that comes up, it should be easy to check (being a
14414    nested function and all).  */
14415
14416 static char *
14417 lang_printable_name (tree decl, int v)
14418 {
14419   /* Just to keep GCC quiet about the unused variable.
14420      In theory, differing values of V should produce different
14421      output.  */
14422   switch (v)
14423     {
14424     default:
14425       if (TREE_CODE (decl) == ERROR_MARK)
14426         return "erroneous code";
14427       return IDENTIFIER_POINTER (DECL_NAME (decl));
14428     }
14429 }
14430
14431 /* g77's function to print out name of current function that caused
14432    an error.  */
14433
14434 #if BUILT_FOR_270
14435 void
14436 lang_print_error_function (file)
14437      char *file;
14438 {
14439   static ffeglobal last_g = NULL;
14440   static ffesymbol last_s = NULL;
14441   ffeglobal g;
14442   ffesymbol s;
14443   const char *kind;
14444
14445   if ((ffecom_primary_entry_ == NULL)
14446       || (ffesymbol_global (ffecom_primary_entry_) == NULL))
14447     {
14448       g = NULL;
14449       s = NULL;
14450       kind = NULL;
14451     }
14452   else
14453     {
14454       g = ffesymbol_global (ffecom_primary_entry_);
14455       if (ffecom_nested_entry_ == NULL)
14456         {
14457           s = ffecom_primary_entry_;
14458           switch (ffesymbol_kind (s))
14459             {
14460             case FFEINFO_kindFUNCTION:
14461               kind = "function";
14462               break;
14463
14464             case FFEINFO_kindSUBROUTINE:
14465               kind = "subroutine";
14466               break;
14467
14468             case FFEINFO_kindPROGRAM:
14469               kind = "program";
14470               break;
14471
14472             case FFEINFO_kindBLOCKDATA:
14473               kind = "block-data";
14474               break;
14475
14476             default:
14477               kind = ffeinfo_kind_message (ffesymbol_kind (s));
14478               break;
14479             }
14480         }
14481       else
14482         {
14483           s = ffecom_nested_entry_;
14484           kind = "statement function";
14485         }
14486     }
14487
14488   if ((last_g != g) || (last_s != s))
14489     {
14490       if (file)
14491         fprintf (stderr, "%s: ", file);
14492
14493       if (s == NULL)
14494         fprintf (stderr, "Outside of any program unit:\n");
14495       else
14496         {
14497           const char *name = ffesymbol_text (s);
14498
14499           fprintf (stderr, "In %s `%s':\n", kind, name);
14500         }
14501
14502       last_g = g;
14503       last_s = s;
14504     }
14505 }
14506 #endif
14507
14508 /* Similar to `lookup_name' but look only at current binding level.  */
14509
14510 static tree
14511 lookup_name_current_level (tree name)
14512 {
14513   register tree t;
14514
14515   if (current_binding_level == global_binding_level)
14516     return IDENTIFIER_GLOBAL_VALUE (name);
14517
14518   if (IDENTIFIER_LOCAL_VALUE (name) == 0)
14519     return 0;
14520
14521   for (t = current_binding_level->names; t; t = TREE_CHAIN (t))
14522     if (DECL_NAME (t) == name)
14523       break;
14524
14525   return t;
14526 }
14527
14528 /* Create a new `struct binding_level'.  */
14529
14530 static struct binding_level *
14531 make_binding_level ()
14532 {
14533   /* NOSTRICT */
14534   return (struct binding_level *) xmalloc (sizeof (struct binding_level));
14535 }
14536
14537 /* Save and restore the variables in this file and elsewhere
14538    that keep track of the progress of compilation of the current function.
14539    Used for nested functions.  */
14540
14541 struct f_function
14542 {
14543   struct f_function *next;
14544   tree named_labels;
14545   tree shadowed_labels;
14546   struct binding_level *binding_level;
14547 };
14548
14549 struct f_function *f_function_chain;
14550
14551 /* Restore the variables used during compilation of a C function.  */
14552
14553 static void
14554 pop_f_function_context ()
14555 {
14556   struct f_function *p = f_function_chain;
14557   tree link;
14558
14559   /* Bring back all the labels that were shadowed.  */
14560   for (link = shadowed_labels; link; link = TREE_CHAIN (link))
14561     if (DECL_NAME (TREE_VALUE (link)) != 0)
14562       IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link)))
14563         = TREE_VALUE (link);
14564
14565   if (current_function_decl != error_mark_node
14566       && DECL_SAVED_INSNS (current_function_decl) == 0)
14567     {
14568       /* Stop pointing to the local nodes about to be freed.  */
14569       /* But DECL_INITIAL must remain nonzero so we know this was an actual
14570          function definition.  */
14571       DECL_INITIAL (current_function_decl) = error_mark_node;
14572       DECL_ARGUMENTS (current_function_decl) = 0;
14573     }
14574
14575   pop_function_context ();
14576
14577   f_function_chain = p->next;
14578
14579   named_labels = p->named_labels;
14580   shadowed_labels = p->shadowed_labels;
14581   current_binding_level = p->binding_level;
14582
14583   free (p);
14584 }
14585
14586 /* Save and reinitialize the variables
14587    used during compilation of a C function.  */
14588
14589 static void
14590 push_f_function_context ()
14591 {
14592   struct f_function *p
14593   = (struct f_function *) xmalloc (sizeof (struct f_function));
14594
14595   push_function_context ();
14596
14597   p->next = f_function_chain;
14598   f_function_chain = p;
14599
14600   p->named_labels = named_labels;
14601   p->shadowed_labels = shadowed_labels;
14602   p->binding_level = current_binding_level;
14603 }
14604
14605 static void
14606 push_parm_decl (tree parm)
14607 {
14608   int old_immediate_size_expand = immediate_size_expand;
14609
14610   /* Don't try computing parm sizes now -- wait till fn is called.  */
14611
14612   immediate_size_expand = 0;
14613
14614   push_obstacks_nochange ();
14615
14616   /* Fill in arg stuff.  */
14617
14618   DECL_ARG_TYPE (parm) = TREE_TYPE (parm);
14619   DECL_ARG_TYPE_AS_WRITTEN (parm) = TREE_TYPE (parm);
14620   TREE_READONLY (parm) = 1;     /* All implementation args are read-only. */
14621
14622   parm = pushdecl (parm);
14623
14624   immediate_size_expand = old_immediate_size_expand;
14625
14626   finish_decl (parm, NULL_TREE, FALSE);
14627 }
14628
14629 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate.  */
14630
14631 static tree
14632 pushdecl_top_level (x)
14633      tree x;
14634 {
14635   register tree t;
14636   register struct binding_level *b = current_binding_level;
14637   register tree f = current_function_decl;
14638
14639   current_binding_level = global_binding_level;
14640   current_function_decl = NULL_TREE;
14641   t = pushdecl (x);
14642   current_binding_level = b;
14643   current_function_decl = f;
14644   return t;
14645 }
14646
14647 /* Store the list of declarations of the current level.
14648    This is done for the parameter declarations of a function being defined,
14649    after they are modified in the light of any missing parameters.  */
14650
14651 static tree
14652 storedecls (decls)
14653      tree decls;
14654 {
14655   return current_binding_level->names = decls;
14656 }
14657
14658 /* Store the parameter declarations into the current function declaration.
14659    This is called after parsing the parameter declarations, before
14660    digesting the body of the function.
14661
14662    For an old-style definition, modify the function's type
14663    to specify at least the number of arguments.  */
14664
14665 static void
14666 store_parm_decls (int is_main_program UNUSED)
14667 {
14668   register tree fndecl = current_function_decl;
14669
14670   if (fndecl == error_mark_node)
14671     return;
14672
14673   /* This is a chain of PARM_DECLs from old-style parm declarations.  */
14674   DECL_ARGUMENTS (fndecl) = storedecls (nreverse (getdecls ()));
14675
14676   /* Initialize the RTL code for the function.  */
14677
14678   init_function_start (fndecl, input_filename, lineno);
14679
14680   /* Set up parameters and prepare for return, for the function.  */
14681
14682   expand_function_start (fndecl, 0);
14683 }
14684
14685 static tree
14686 start_decl (tree decl, bool is_top_level)
14687 {
14688   register tree tem;
14689   bool at_top_level = (current_binding_level == global_binding_level);
14690   bool top_level = is_top_level || at_top_level;
14691
14692   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
14693      level anyway.  */
14694   assert (!is_top_level || !at_top_level);
14695
14696   /* The corresponding pop_obstacks is in finish_decl.  */
14697   push_obstacks_nochange ();
14698
14699   if (DECL_INITIAL (decl) != NULL_TREE)
14700     {
14701       assert (DECL_INITIAL (decl) == error_mark_node);
14702       assert (!DECL_EXTERNAL (decl));
14703     }
14704   else if (top_level)
14705     assert ((TREE_STATIC (decl) == 1) || DECL_EXTERNAL (decl) == 1);
14706
14707   /* For Fortran, we by default put things in .common when possible.  */
14708   DECL_COMMON (decl) = 1;
14709
14710   /* Add this decl to the current binding level. TEM may equal DECL or it may
14711      be a previous decl of the same name.  */
14712   if (is_top_level)
14713     tem = pushdecl_top_level (decl);
14714   else
14715     tem = pushdecl (decl);
14716
14717   /* For a local variable, define the RTL now.  */
14718   if (!top_level
14719   /* But not if this is a duplicate decl and we preserved the rtl from the
14720      previous one (which may or may not happen).  */
14721       && DECL_RTL (tem) == 0)
14722     {
14723       if (TYPE_SIZE (TREE_TYPE (tem)) != 0)
14724         expand_decl (tem);
14725       else if (TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE
14726                && DECL_INITIAL (tem) != 0)
14727         expand_decl (tem);
14728     }
14729
14730   if (DECL_INITIAL (tem) != NULL_TREE)
14731     {
14732       /* When parsing and digesting the initializer, use temporary storage.
14733          Do this even if we will ignore the value.  */
14734       if (at_top_level)
14735         temporary_allocation ();
14736     }
14737
14738   return tem;
14739 }
14740
14741 /* Create the FUNCTION_DECL for a function definition.
14742    DECLSPECS and DECLARATOR are the parts of the declaration;
14743    they describe the function's name and the type it returns,
14744    but twisted together in a fashion that parallels the syntax of C.
14745
14746    This function creates a binding context for the function body
14747    as well as setting up the FUNCTION_DECL in current_function_decl.
14748
14749    Returns 1 on success.  If the DECLARATOR is not suitable for a function
14750    (it defines a datum instead), we return 0, which tells
14751    yyparse to report a parse error.
14752
14753    NESTED is nonzero for a function nested within another function.  */
14754
14755 static void
14756 start_function (tree name, tree type, int nested, int public)
14757 {
14758   tree decl1;
14759   tree restype;
14760   int old_immediate_size_expand = immediate_size_expand;
14761
14762   named_labels = 0;
14763   shadowed_labels = 0;
14764
14765   /* Don't expand any sizes in the return type of the function.  */
14766   immediate_size_expand = 0;
14767
14768   if (nested)
14769     {
14770       assert (!public);
14771       assert (current_function_decl != NULL_TREE);
14772       assert (DECL_CONTEXT (current_function_decl) == NULL_TREE);
14773     }
14774   else
14775     {
14776       assert (current_function_decl == NULL_TREE);
14777     }
14778
14779   if (TREE_CODE (type) == ERROR_MARK)
14780     decl1 = current_function_decl = error_mark_node;
14781   else
14782     {
14783       decl1 = build_decl (FUNCTION_DECL,
14784                           name,
14785                           type);
14786       TREE_PUBLIC (decl1) = public ? 1 : 0;
14787       if (nested)
14788         DECL_INLINE (decl1) = 1;
14789       TREE_STATIC (decl1) = 1;
14790       DECL_EXTERNAL (decl1) = 0;
14791
14792       announce_function (decl1);
14793
14794       /* Make the init_value nonzero so pushdecl knows this is not tentative.
14795          error_mark_node is replaced below (in poplevel) with the BLOCK.  */
14796       DECL_INITIAL (decl1) = error_mark_node;
14797
14798       /* Record the decl so that the function name is defined. If we already have
14799          a decl for this name, and it is a FUNCTION_DECL, use the old decl.  */
14800
14801       current_function_decl = pushdecl (decl1);
14802     }
14803
14804   if (!nested)
14805     ffecom_outer_function_decl_ = current_function_decl;
14806
14807   pushlevel (0);
14808   current_binding_level->prep_state = 2;
14809
14810   if (TREE_CODE (current_function_decl) != ERROR_MARK)
14811     {
14812       make_function_rtl (current_function_decl);
14813
14814       restype = TREE_TYPE (TREE_TYPE (current_function_decl));
14815       DECL_RESULT (current_function_decl)
14816         = build_decl (RESULT_DECL, NULL_TREE, restype);
14817     }
14818
14819   if (!nested)
14820     /* Allocate further tree nodes temporarily during compilation of this
14821        function only.  */
14822     temporary_allocation ();
14823
14824   if (!nested && (TREE_CODE (current_function_decl) != ERROR_MARK))
14825     TREE_ADDRESSABLE (current_function_decl) = 1;
14826
14827   immediate_size_expand = old_immediate_size_expand;
14828 }
14829 \f
14830 /* Here are the public functions the GNU back end needs.  */
14831
14832 tree
14833 convert (type, expr)
14834      tree type, expr;
14835 {
14836   register tree e = expr;
14837   register enum tree_code code = TREE_CODE (type);
14838
14839   if (type == TREE_TYPE (e)
14840       || TREE_CODE (e) == ERROR_MARK)
14841     return e;
14842   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
14843     return fold (build1 (NOP_EXPR, type, e));
14844   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
14845       || code == ERROR_MARK)
14846     return error_mark_node;
14847   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
14848     {
14849       assert ("void value not ignored as it ought to be" == NULL);
14850       return error_mark_node;
14851     }
14852   if (code == VOID_TYPE)
14853     return build1 (CONVERT_EXPR, type, e);
14854   if ((code != RECORD_TYPE)
14855       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
14856     e = ffecom_1 (REALPART_EXPR, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))),
14857                   e);
14858   if (code == INTEGER_TYPE || code == ENUMERAL_TYPE)
14859     return fold (convert_to_integer (type, e));
14860   if (code == POINTER_TYPE)
14861     return fold (convert_to_pointer (type, e));
14862   if (code == REAL_TYPE)
14863     return fold (convert_to_real (type, e));
14864   if (code == COMPLEX_TYPE)
14865     return fold (convert_to_complex (type, e));
14866   if (code == RECORD_TYPE)
14867     return fold (ffecom_convert_to_complex_ (type, e));
14868
14869   assert ("conversion to non-scalar type requested" == NULL);
14870   return error_mark_node;
14871 }
14872
14873 /* integrate_decl_tree calls this function, but since we don't use the
14874    DECL_LANG_SPECIFIC field, this is a no-op.  */
14875
14876 void
14877 copy_lang_decl (node)
14878      tree node UNUSED;
14879 {
14880 }
14881
14882 /* Return the list of declarations of the current level.
14883    Note that this list is in reverse order unless/until
14884    you nreverse it; and when you do nreverse it, you must
14885    store the result back using `storedecls' or you will lose.  */
14886
14887 tree
14888 getdecls ()
14889 {
14890   return current_binding_level->names;
14891 }
14892
14893 /* Nonzero if we are currently in the global binding level.  */
14894
14895 int
14896 global_bindings_p ()
14897 {
14898   return current_binding_level == global_binding_level;
14899 }
14900
14901 /* Print an error message for invalid use of an incomplete type.
14902    VALUE is the expression that was used (or 0 if that isn't known)
14903    and TYPE is the type that was invalid.  */
14904
14905 void
14906 incomplete_type_error (value, type)
14907      tree value UNUSED;
14908      tree type;
14909 {
14910   if (TREE_CODE (type) == ERROR_MARK)
14911     return;
14912
14913   assert ("incomplete type?!?" == NULL);
14914 }
14915
14916 void
14917 init_decl_processing ()
14918 {
14919   malloc_init ();
14920   ffe_init_0 ();
14921 }
14922
14923 char *
14924 init_parse (filename)
14925      char *filename;
14926 {
14927 #if BUILT_FOR_270
14928   extern void (*print_error_function) (char *);
14929 #endif
14930
14931   /* Open input file.  */
14932   if (filename == 0 || !strcmp (filename, "-"))
14933     {
14934       finput = stdin;
14935       filename = "stdin";
14936     }
14937   else
14938     finput = fopen (filename, "r");
14939   if (finput == 0)
14940     pfatal_with_name (filename);
14941
14942 #ifdef IO_BUFFER_SIZE
14943   setvbuf (finput, (char *) xmalloc (IO_BUFFER_SIZE), _IOFBF, IO_BUFFER_SIZE);
14944 #endif
14945
14946   /* Make identifier nodes long enough for the language-specific slots.  */
14947   set_identifier_size (sizeof (struct lang_identifier));
14948   decl_printable_name = lang_printable_name;
14949 #if BUILT_FOR_270
14950   print_error_function = lang_print_error_function;
14951 #endif
14952
14953   return filename;
14954 }
14955
14956 void
14957 finish_parse ()
14958 {
14959   fclose (finput);
14960 }
14961
14962 /* Delete the node BLOCK from the current binding level.
14963    This is used for the block inside a stmt expr ({...})
14964    so that the block can be reinserted where appropriate.  */
14965
14966 static void
14967 delete_block (block)
14968      tree block;
14969 {
14970   tree t;
14971   if (current_binding_level->blocks == block)
14972     current_binding_level->blocks = TREE_CHAIN (block);
14973   for (t = current_binding_level->blocks; t;)
14974     {
14975       if (TREE_CHAIN (t) == block)
14976         TREE_CHAIN (t) = TREE_CHAIN (block);
14977       else
14978         t = TREE_CHAIN (t);
14979     }
14980   TREE_CHAIN (block) = NULL;
14981   /* Clear TREE_USED which is always set by poplevel.
14982      The flag is set again if insert_block is called.  */
14983   TREE_USED (block) = 0;
14984 }
14985
14986 void
14987 insert_block (block)
14988      tree block;
14989 {
14990   TREE_USED (block) = 1;
14991   current_binding_level->blocks
14992     = chainon (current_binding_level->blocks, block);
14993 }
14994
14995 int
14996 lang_decode_option (argc, argv)
14997      int argc;
14998      char **argv;
14999 {
15000   return ffe_decode_option (argc, argv);
15001 }
15002
15003 /* used by print-tree.c */
15004
15005 void
15006 lang_print_xnode (file, node, indent)
15007      FILE *file UNUSED;
15008      tree node UNUSED;
15009      int indent UNUSED;
15010 {
15011 }
15012
15013 void
15014 lang_finish ()
15015 {
15016   ffe_terminate_0 ();
15017
15018   if (ffe_is_ffedebug ())
15019     malloc_pool_display (malloc_pool_image ());
15020 }
15021
15022 char *
15023 lang_identify ()
15024 {
15025   return "f77";
15026 }
15027
15028 void
15029 lang_init_options ()
15030 {
15031   /* Set default options for Fortran.  */
15032   flag_move_all_movables = 1;
15033   flag_reduce_all_givs = 1;
15034   flag_argument_noalias = 2;
15035   flag_errno_math = 0;
15036   flag_complex_divide_method = 1;
15037 }
15038
15039 void
15040 lang_init ()
15041 {
15042   /* If the file is output from cpp, it should contain a first line
15043      `# 1 "real-filename"', and the current design of gcc (toplev.c
15044      in particular and the way it sets up information relied on by
15045      INCLUDE) requires that we read this now, and store the
15046      "real-filename" info in master_input_filename.  Ask the lexer
15047      to try doing this.  */
15048   ffelex_hash_kludge (finput);
15049 }
15050
15051 int
15052 mark_addressable (exp)
15053      tree exp;
15054 {
15055   register tree x = exp;
15056   while (1)
15057     switch (TREE_CODE (x))
15058       {
15059       case ADDR_EXPR:
15060       case COMPONENT_REF:
15061       case ARRAY_REF:
15062         x = TREE_OPERAND (x, 0);
15063         break;
15064
15065       case CONSTRUCTOR:
15066         TREE_ADDRESSABLE (x) = 1;
15067         return 1;
15068
15069       case VAR_DECL:
15070       case CONST_DECL:
15071       case PARM_DECL:
15072       case RESULT_DECL:
15073         if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)
15074             && DECL_NONLOCAL (x))
15075           {
15076             if (TREE_PUBLIC (x))
15077               {
15078                 assert ("address of global register var requested" == NULL);
15079                 return 0;
15080               }
15081             assert ("address of register variable requested" == NULL);
15082           }
15083         else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
15084           {
15085             if (TREE_PUBLIC (x))
15086               {
15087                 assert ("address of global register var requested" == NULL);
15088                 return 0;
15089               }
15090             assert ("address of register var requested" == NULL);
15091           }
15092         put_var_into_stack (x);
15093
15094         /* drops in */
15095       case FUNCTION_DECL:
15096         TREE_ADDRESSABLE (x) = 1;
15097 #if 0                           /* poplevel deals with this now.  */
15098         if (DECL_CONTEXT (x) == 0)
15099           TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1;
15100 #endif
15101
15102       default:
15103         return 1;
15104       }
15105 }
15106
15107 /* If DECL has a cleanup, build and return that cleanup here.
15108    This is a callback called by expand_expr.  */
15109
15110 tree
15111 maybe_build_cleanup (decl)
15112      tree decl UNUSED;
15113 {
15114   /* There are no cleanups in Fortran.  */
15115   return NULL_TREE;
15116 }
15117
15118 /* Exit a binding level.
15119    Pop the level off, and restore the state of the identifier-decl mappings
15120    that were in effect when this level was entered.
15121
15122    If KEEP is nonzero, this level had explicit declarations, so
15123    and create a "block" (a BLOCK node) for the level
15124    to record its declarations and subblocks for symbol table output.
15125
15126    If FUNCTIONBODY is nonzero, this level is the body of a function,
15127    so create a block as if KEEP were set and also clear out all
15128    label names.
15129
15130    If REVERSE is nonzero, reverse the order of decls before putting
15131    them into the BLOCK.  */
15132
15133 tree
15134 poplevel (keep, reverse, functionbody)
15135      int keep;
15136      int reverse;
15137      int functionbody;
15138 {
15139   register tree link;
15140   /* The chain of decls was accumulated in reverse order.
15141      Put it into forward order, just for cleanliness.  */
15142   tree decls;
15143   tree subblocks = current_binding_level->blocks;
15144   tree block = 0;
15145   tree decl;
15146   int block_previously_created;
15147
15148   /* Get the decls in the order they were written.
15149      Usually current_binding_level->names is in reverse order.
15150      But parameter decls were previously put in forward order.  */
15151
15152   if (reverse)
15153     current_binding_level->names
15154       = decls = nreverse (current_binding_level->names);
15155   else
15156     decls = current_binding_level->names;
15157
15158   /* Output any nested inline functions within this block
15159      if they weren't already output.  */
15160
15161   for (decl = decls; decl; decl = TREE_CHAIN (decl))
15162     if (TREE_CODE (decl) == FUNCTION_DECL
15163         && ! TREE_ASM_WRITTEN (decl)
15164         && DECL_INITIAL (decl) != 0
15165         && TREE_ADDRESSABLE (decl))
15166       {
15167         /* If this decl was copied from a file-scope decl
15168            on account of a block-scope extern decl,
15169            propagate TREE_ADDRESSABLE to the file-scope decl.
15170
15171            DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
15172            true, since then the decl goes through save_for_inline_copying.  */
15173         if (DECL_ABSTRACT_ORIGIN (decl) != 0
15174             && DECL_ABSTRACT_ORIGIN (decl) != decl)
15175           TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1;
15176         else if (DECL_SAVED_INSNS (decl) != 0)
15177           {
15178             push_function_context ();
15179             output_inline_function (decl);
15180             pop_function_context ();
15181           }
15182       }
15183
15184   /* If there were any declarations or structure tags in that level,
15185      or if this level is a function body,
15186      create a BLOCK to record them for the life of this function.  */
15187
15188   block = 0;
15189   block_previously_created = (current_binding_level->this_block != 0);
15190   if (block_previously_created)
15191     block = current_binding_level->this_block;
15192   else if (keep || functionbody)
15193     block = make_node (BLOCK);
15194   if (block != 0)
15195     {
15196       BLOCK_VARS (block) = decls;
15197       BLOCK_SUBBLOCKS (block) = subblocks;
15198       remember_end_note (block);
15199     }
15200
15201   /* In each subblock, record that this is its superior.  */
15202
15203   for (link = subblocks; link; link = TREE_CHAIN (link))
15204     BLOCK_SUPERCONTEXT (link) = block;
15205
15206   /* Clear out the meanings of the local variables of this level.  */
15207
15208   for (link = decls; link; link = TREE_CHAIN (link))
15209     {
15210       if (DECL_NAME (link) != 0)
15211         {
15212           /* If the ident. was used or addressed via a local extern decl,
15213              don't forget that fact.  */
15214           if (DECL_EXTERNAL (link))
15215             {
15216               if (TREE_USED (link))
15217                 TREE_USED (DECL_NAME (link)) = 1;
15218               if (TREE_ADDRESSABLE (link))
15219                 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link)) = 1;
15220             }
15221           IDENTIFIER_LOCAL_VALUE (DECL_NAME (link)) = 0;
15222         }
15223     }
15224
15225   /* If the level being exited is the top level of a function,
15226      check over all the labels, and clear out the current
15227      (function local) meanings of their names.  */
15228
15229   if (functionbody)
15230     {
15231       /* If this is the top level block of a function,
15232          the vars are the function's parameters.
15233          Don't leave them in the BLOCK because they are
15234          found in the FUNCTION_DECL instead.  */
15235
15236       BLOCK_VARS (block) = 0;
15237     }
15238
15239   /* Pop the current level, and free the structure for reuse.  */
15240
15241   {
15242     register struct binding_level *level = current_binding_level;
15243     current_binding_level = current_binding_level->level_chain;
15244
15245     level->level_chain = free_binding_level;
15246     free_binding_level = level;
15247   }
15248
15249   /* Dispose of the block that we just made inside some higher level.  */
15250   if (functionbody
15251       && current_function_decl != error_mark_node)
15252     DECL_INITIAL (current_function_decl) = block;
15253   else if (block)
15254     {
15255       if (!block_previously_created)
15256         current_binding_level->blocks
15257           = chainon (current_binding_level->blocks, block);
15258     }
15259   /* If we did not make a block for the level just exited,
15260      any blocks made for inner levels
15261      (since they cannot be recorded as subblocks in that level)
15262      must be carried forward so they will later become subblocks
15263      of something else.  */
15264   else if (subblocks)
15265     current_binding_level->blocks
15266       = chainon (current_binding_level->blocks, subblocks);
15267
15268   if (block)
15269     TREE_USED (block) = 1;
15270   return block;
15271 }
15272
15273 void
15274 print_lang_decl (file, node, indent)
15275      FILE *file UNUSED;
15276      tree node UNUSED;
15277      int indent UNUSED;
15278 {
15279 }
15280
15281 void
15282 print_lang_identifier (file, node, indent)
15283      FILE *file;
15284      tree node;
15285      int indent;
15286 {
15287   print_node (file, "global", IDENTIFIER_GLOBAL_VALUE (node), indent + 4);
15288   print_node (file, "local", IDENTIFIER_LOCAL_VALUE (node), indent + 4);
15289 }
15290
15291 void
15292 print_lang_statistics ()
15293 {
15294 }
15295
15296 void
15297 print_lang_type (file, node, indent)
15298      FILE *file UNUSED;
15299      tree node UNUSED;
15300      int indent UNUSED;
15301 {
15302 }
15303
15304 /* Record a decl-node X as belonging to the current lexical scope.
15305    Check for errors (such as an incompatible declaration for the same
15306    name already seen in the same scope).
15307
15308    Returns either X or an old decl for the same name.
15309    If an old decl is returned, it may have been smashed
15310    to agree with what X says.  */
15311
15312 tree
15313 pushdecl (x)
15314      tree x;
15315 {
15316   register tree t;
15317   register tree name = DECL_NAME (x);
15318   register struct binding_level *b = current_binding_level;
15319
15320   if ((TREE_CODE (x) == FUNCTION_DECL)
15321       && (DECL_INITIAL (x) == 0)
15322       && DECL_EXTERNAL (x))
15323     DECL_CONTEXT (x) = NULL_TREE;
15324   else
15325     DECL_CONTEXT (x) = current_function_decl;
15326
15327   if (name)
15328     {
15329       if (IDENTIFIER_INVENTED (name))
15330         {
15331 #if BUILT_FOR_270
15332           DECL_ARTIFICIAL (x) = 1;
15333 #endif
15334           DECL_IN_SYSTEM_HEADER (x) = 1;
15335         }
15336
15337       t = lookup_name_current_level (name);
15338
15339       assert ((t == NULL_TREE) || (DECL_CONTEXT (x) == NULL_TREE));
15340
15341       /* Don't push non-parms onto list for parms until we understand
15342          why we're doing this and whether it works.  */
15343
15344       assert ((b == global_binding_level)
15345               || !ffecom_transform_only_dummies_
15346               || TREE_CODE (x) == PARM_DECL);
15347
15348       if ((t != NULL_TREE) && duplicate_decls (x, t))
15349         return t;
15350
15351       /* If we are processing a typedef statement, generate a whole new
15352          ..._TYPE node (which will be just an variant of the existing
15353          ..._TYPE node with identical properties) and then install the
15354          TYPE_DECL node generated to represent the typedef name as the
15355          TYPE_NAME of this brand new (duplicate) ..._TYPE node.
15356
15357          The whole point here is to end up with a situation where each and every
15358          ..._TYPE node the compiler creates will be uniquely associated with
15359          AT MOST one node representing a typedef name. This way, even though
15360          the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
15361          (i.e. "typedef name") nodes very early on, later parts of the
15362          compiler can always do the reverse translation and get back the
15363          corresponding typedef name.  For example, given:
15364
15365          typedef struct S MY_TYPE; MY_TYPE object;
15366
15367          Later parts of the compiler might only know that `object' was of type
15368          `struct S' if it were not for code just below.  With this code
15369          however, later parts of the compiler see something like:
15370
15371          struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
15372
15373          And they can then deduce (from the node for type struct S') that the
15374          original object declaration was:
15375
15376          MY_TYPE object;
15377
15378          Being able to do this is important for proper support of protoize, and
15379          also for generating precise symbolic debugging information which
15380          takes full account of the programmer's (typedef) vocabulary.
15381
15382          Obviously, we don't want to generate a duplicate ..._TYPE node if the
15383          TYPE_DECL node that we are now processing really represents a
15384          standard built-in type.
15385
15386          Since all standard types are effectively declared at line zero in the
15387          source file, we can easily check to see if we are working on a
15388          standard type by checking the current value of lineno.  */
15389
15390       if (TREE_CODE (x) == TYPE_DECL)
15391         {
15392           if (DECL_SOURCE_LINE (x) == 0)
15393             {
15394               if (TYPE_NAME (TREE_TYPE (x)) == 0)
15395                 TYPE_NAME (TREE_TYPE (x)) = x;
15396             }
15397           else if (TREE_TYPE (x) != error_mark_node)
15398             {
15399               tree tt = TREE_TYPE (x);
15400
15401               tt = build_type_copy (tt);
15402               TYPE_NAME (tt) = x;
15403               TREE_TYPE (x) = tt;
15404             }
15405         }
15406
15407       /* This name is new in its binding level. Install the new declaration
15408          and return it.  */
15409       if (b == global_binding_level)
15410         IDENTIFIER_GLOBAL_VALUE (name) = x;
15411       else
15412         IDENTIFIER_LOCAL_VALUE (name) = x;
15413     }
15414
15415   /* Put decls on list in reverse order. We will reverse them later if
15416      necessary.  */
15417   TREE_CHAIN (x) = b->names;
15418   b->names = x;
15419
15420   return x;
15421 }
15422
15423 /* Nonzero if the current level needs to have a BLOCK made.  */
15424
15425 static int
15426 kept_level_p ()
15427 {
15428   tree decl;
15429
15430   for (decl = current_binding_level->names;
15431        decl;
15432        decl = TREE_CHAIN (decl))
15433     {
15434       if (TREE_USED (decl) || TREE_CODE (decl) != VAR_DECL
15435           || (DECL_NAME (decl) && ! DECL_ARTIFICIAL (decl)))
15436         /* Currently, there aren't supposed to be non-artificial names
15437            at other than the top block for a function -- they're
15438            believed to always be temps.  But it's wise to check anyway.  */
15439         return 1;
15440     }
15441   return 0;
15442 }
15443
15444 /* Enter a new binding level.
15445    If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
15446    not for that of tags.  */
15447
15448 void
15449 pushlevel (tag_transparent)
15450      int tag_transparent;
15451 {
15452   register struct binding_level *newlevel = NULL_BINDING_LEVEL;
15453
15454   assert (! tag_transparent);
15455
15456   if (current_binding_level == global_binding_level)
15457     {
15458       named_labels = 0;
15459     }
15460
15461   /* Reuse or create a struct for this binding level.  */
15462
15463   if (free_binding_level)
15464     {
15465       newlevel = free_binding_level;
15466       free_binding_level = free_binding_level->level_chain;
15467     }
15468   else
15469     {
15470       newlevel = make_binding_level ();
15471     }
15472
15473   /* Add this level to the front of the chain (stack) of levels that
15474      are active.  */
15475
15476   *newlevel = clear_binding_level;
15477   newlevel->level_chain = current_binding_level;
15478   current_binding_level = newlevel;
15479 }
15480
15481 /* Set the BLOCK node for the innermost scope
15482    (the one we are currently in).  */
15483
15484 void
15485 set_block (block)
15486      register tree block;
15487 {
15488   current_binding_level->this_block = block;
15489 }
15490
15491 /* ~~gcc/tree.h *should* declare this, because toplev.c references it.  */
15492
15493 /* Can't 'yydebug' a front end not generated by yacc/bison!  */
15494
15495 void
15496 set_yydebug (value)
15497      int value;
15498 {
15499   if (value)
15500     fprintf (stderr, "warning: no yacc/bison-generated output to debug!\n");
15501 }
15502
15503 tree
15504 signed_or_unsigned_type (unsignedp, type)
15505      int unsignedp;
15506      tree type;
15507 {
15508   tree type2;
15509
15510   if (! INTEGRAL_TYPE_P (type))
15511     return type;
15512   if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
15513     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15514   if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
15515     return unsignedp ? unsigned_type_node : integer_type_node;
15516   if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
15517     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15518   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
15519     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15520   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
15521     return (unsignedp ? long_long_unsigned_type_node
15522             : long_long_integer_type_node);
15523
15524   type2 = type_for_size (TYPE_PRECISION (type), unsignedp);
15525   if (type2 == NULL_TREE)
15526     return type;
15527
15528   return type2;
15529 }
15530
15531 tree
15532 signed_type (type)
15533      tree type;
15534 {
15535   tree type1 = TYPE_MAIN_VARIANT (type);
15536   ffeinfoKindtype kt;
15537   tree type2;
15538
15539   if (type1 == unsigned_char_type_node || type1 == char_type_node)
15540     return signed_char_type_node;
15541   if (type1 == unsigned_type_node)
15542     return integer_type_node;
15543   if (type1 == short_unsigned_type_node)
15544     return short_integer_type_node;
15545   if (type1 == long_unsigned_type_node)
15546     return long_integer_type_node;
15547   if (type1 == long_long_unsigned_type_node)
15548     return long_long_integer_type_node;
15549 #if 0   /* gcc/c-* files only */
15550   if (type1 == unsigned_intDI_type_node)
15551     return intDI_type_node;
15552   if (type1 == unsigned_intSI_type_node)
15553     return intSI_type_node;
15554   if (type1 == unsigned_intHI_type_node)
15555     return intHI_type_node;
15556   if (type1 == unsigned_intQI_type_node)
15557     return intQI_type_node;
15558 #endif
15559
15560   type2 = type_for_size (TYPE_PRECISION (type1), 0);
15561   if (type2 != NULL_TREE)
15562     return type2;
15563
15564   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15565     {
15566       type2 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15567
15568       if (type1 == type2)
15569         return ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15570     }
15571
15572   return type;
15573 }
15574
15575 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
15576    or validate its data type for an `if' or `while' statement or ?..: exp.
15577
15578    This preparation consists of taking the ordinary
15579    representation of an expression expr and producing a valid tree
15580    boolean expression describing whether expr is nonzero.  We could
15581    simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
15582    but we optimize comparisons, &&, ||, and !.
15583
15584    The resulting type should always be `integer_type_node'.  */
15585
15586 tree
15587 truthvalue_conversion (expr)
15588      tree expr;
15589 {
15590   if (TREE_CODE (expr) == ERROR_MARK)
15591     return expr;
15592
15593 #if 0 /* This appears to be wrong for C++.  */
15594   /* These really should return error_mark_node after 2.4 is stable.
15595      But not all callers handle ERROR_MARK properly.  */
15596   switch (TREE_CODE (TREE_TYPE (expr)))
15597     {
15598     case RECORD_TYPE:
15599       error ("struct type value used where scalar is required");
15600       return integer_zero_node;
15601
15602     case UNION_TYPE:
15603       error ("union type value used where scalar is required");
15604       return integer_zero_node;
15605
15606     case ARRAY_TYPE:
15607       error ("array type value used where scalar is required");
15608       return integer_zero_node;
15609
15610     default:
15611       break;
15612     }
15613 #endif /* 0 */
15614
15615   switch (TREE_CODE (expr))
15616     {
15617       /* It is simpler and generates better code to have only TRUTH_*_EXPR
15618          or comparison expressions as truth values at this level.  */
15619 #if 0
15620     case COMPONENT_REF:
15621       /* A one-bit unsigned bit-field is already acceptable.  */
15622       if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr, 1)))
15623           && TREE_UNSIGNED (TREE_OPERAND (expr, 1)))
15624         return expr;
15625       break;
15626 #endif
15627
15628     case EQ_EXPR:
15629       /* It is simpler and generates better code to have only TRUTH_*_EXPR
15630          or comparison expressions as truth values at this level.  */
15631 #if 0
15632       if (integer_zerop (TREE_OPERAND (expr, 1)))
15633         return build_unary_op (TRUTH_NOT_EXPR, TREE_OPERAND (expr, 0), 0);
15634 #endif
15635     case NE_EXPR: case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR:
15636     case TRUTH_ANDIF_EXPR:
15637     case TRUTH_ORIF_EXPR:
15638     case TRUTH_AND_EXPR:
15639     case TRUTH_OR_EXPR:
15640     case TRUTH_XOR_EXPR:
15641       TREE_TYPE (expr) = integer_type_node;
15642       return expr;
15643
15644     case ERROR_MARK:
15645       return expr;
15646
15647     case INTEGER_CST:
15648       return integer_zerop (expr) ? integer_zero_node : integer_one_node;
15649
15650     case REAL_CST:
15651       return real_zerop (expr) ? integer_zero_node : integer_one_node;
15652
15653     case ADDR_EXPR:
15654       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 0)))
15655         return build (COMPOUND_EXPR, integer_type_node,
15656                       TREE_OPERAND (expr, 0), integer_one_node);
15657       else
15658         return integer_one_node;
15659
15660     case COMPLEX_EXPR:
15661       return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1))
15662                         ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
15663                        integer_type_node,
15664                        truthvalue_conversion (TREE_OPERAND (expr, 0)),
15665                        truthvalue_conversion (TREE_OPERAND (expr, 1)));
15666
15667     case NEGATE_EXPR:
15668     case ABS_EXPR:
15669     case FLOAT_EXPR:
15670     case FFS_EXPR:
15671       /* These don't change whether an object is non-zero or zero.  */
15672       return truthvalue_conversion (TREE_OPERAND (expr, 0));
15673
15674     case LROTATE_EXPR:
15675     case RROTATE_EXPR:
15676       /* These don't change whether an object is zero or non-zero, but
15677          we can't ignore them if their second arg has side-effects.  */
15678       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)))
15679         return build (COMPOUND_EXPR, integer_type_node, TREE_OPERAND (expr, 1),
15680                       truthvalue_conversion (TREE_OPERAND (expr, 0)));
15681       else
15682         return truthvalue_conversion (TREE_OPERAND (expr, 0));
15683
15684     case COND_EXPR:
15685       /* Distribute the conversion into the arms of a COND_EXPR.  */
15686       return fold (build (COND_EXPR, integer_type_node, TREE_OPERAND (expr, 0),
15687                           truthvalue_conversion (TREE_OPERAND (expr, 1)),
15688                           truthvalue_conversion (TREE_OPERAND (expr, 2))));
15689
15690     case CONVERT_EXPR:
15691       /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
15692          since that affects how `default_conversion' will behave.  */
15693       if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE
15694           || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE)
15695         break;
15696       /* fall through... */
15697     case NOP_EXPR:
15698       /* If this is widening the argument, we can ignore it.  */
15699       if (TYPE_PRECISION (TREE_TYPE (expr))
15700           >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0))))
15701         return truthvalue_conversion (TREE_OPERAND (expr, 0));
15702       break;
15703
15704     case MINUS_EXPR:
15705       /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
15706          this case.  */
15707       if (TARGET_FLOAT_FORMAT == IEEE_FLOAT_FORMAT
15708           && TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE)
15709         break;
15710       /* fall through... */
15711     case BIT_XOR_EXPR:
15712       /* This and MINUS_EXPR can be changed into a comparison of the
15713          two objects.  */
15714       if (TREE_TYPE (TREE_OPERAND (expr, 0))
15715           == TREE_TYPE (TREE_OPERAND (expr, 1)))
15716         return ffecom_2 (NE_EXPR, integer_type_node,
15717                          TREE_OPERAND (expr, 0),
15718                          TREE_OPERAND (expr, 1));
15719       return ffecom_2 (NE_EXPR, integer_type_node,
15720                        TREE_OPERAND (expr, 0),
15721                        fold (build1 (NOP_EXPR,
15722                                      TREE_TYPE (TREE_OPERAND (expr, 0)),
15723                                      TREE_OPERAND (expr, 1))));
15724
15725     case BIT_AND_EXPR:
15726       if (integer_onep (TREE_OPERAND (expr, 1)))
15727         return expr;
15728       break;
15729
15730     case MODIFY_EXPR:
15731 #if 0                           /* No such thing in Fortran. */
15732       if (warn_parentheses && C_EXP_ORIGINAL_CODE (expr) == MODIFY_EXPR)
15733         warning ("suggest parentheses around assignment used as truth value");
15734 #endif
15735       break;
15736
15737     default:
15738       break;
15739     }
15740
15741   if (TREE_CODE (TREE_TYPE (expr)) == COMPLEX_TYPE)
15742     return (ffecom_2
15743             ((TREE_SIDE_EFFECTS (expr)
15744               ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
15745              integer_type_node,
15746              truthvalue_conversion (ffecom_1 (REALPART_EXPR,
15747                                               TREE_TYPE (TREE_TYPE (expr)),
15748                                               expr)),
15749              truthvalue_conversion (ffecom_1 (IMAGPART_EXPR,
15750                                               TREE_TYPE (TREE_TYPE (expr)),
15751                                               expr))));
15752
15753   return ffecom_2 (NE_EXPR, integer_type_node,
15754                    expr,
15755                    convert (TREE_TYPE (expr), integer_zero_node));
15756 }
15757
15758 tree
15759 type_for_mode (mode, unsignedp)
15760      enum machine_mode mode;
15761      int unsignedp;
15762 {
15763   int i;
15764   int j;
15765   tree t;
15766
15767   if (mode == TYPE_MODE (integer_type_node))
15768     return unsignedp ? unsigned_type_node : integer_type_node;
15769
15770   if (mode == TYPE_MODE (signed_char_type_node))
15771     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15772
15773   if (mode == TYPE_MODE (short_integer_type_node))
15774     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15775
15776   if (mode == TYPE_MODE (long_integer_type_node))
15777     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15778
15779   if (mode == TYPE_MODE (long_long_integer_type_node))
15780     return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node;
15781
15782   if (mode == TYPE_MODE (float_type_node))
15783     return float_type_node;
15784
15785   if (mode == TYPE_MODE (double_type_node))
15786     return double_type_node;
15787
15788   if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
15789     return build_pointer_type (char_type_node);
15790
15791   if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
15792     return build_pointer_type (integer_type_node);
15793
15794   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
15795     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
15796       {
15797         if (((t = ffecom_tree_type[i][j]) != NULL_TREE)
15798             && (mode == TYPE_MODE (t)))
15799           {
15800             if ((i == FFEINFO_basictypeINTEGER) && unsignedp)
15801               return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][j];
15802             else
15803               return t;
15804           }
15805       }
15806
15807   return 0;
15808 }
15809
15810 tree
15811 type_for_size (bits, unsignedp)
15812      unsigned bits;
15813      int unsignedp;
15814 {
15815   ffeinfoKindtype kt;
15816   tree type_node;
15817
15818   if (bits == TYPE_PRECISION (integer_type_node))
15819     return unsignedp ? unsigned_type_node : integer_type_node;
15820
15821   if (bits == TYPE_PRECISION (signed_char_type_node))
15822     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15823
15824   if (bits == TYPE_PRECISION (short_integer_type_node))
15825     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15826
15827   if (bits == TYPE_PRECISION (long_integer_type_node))
15828     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15829
15830   if (bits == TYPE_PRECISION (long_long_integer_type_node))
15831     return (unsignedp ? long_long_unsigned_type_node
15832             : long_long_integer_type_node);
15833
15834   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15835     {
15836       type_node = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15837
15838       if ((type_node != NULL_TREE) && (bits == TYPE_PRECISION (type_node)))
15839         return unsignedp ? ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]
15840           : type_node;
15841     }
15842
15843   return 0;
15844 }
15845
15846 tree
15847 unsigned_type (type)
15848      tree type;
15849 {
15850   tree type1 = TYPE_MAIN_VARIANT (type);
15851   ffeinfoKindtype kt;
15852   tree type2;
15853
15854   if (type1 == signed_char_type_node || type1 == char_type_node)
15855     return unsigned_char_type_node;
15856   if (type1 == integer_type_node)
15857     return unsigned_type_node;
15858   if (type1 == short_integer_type_node)
15859     return short_unsigned_type_node;
15860   if (type1 == long_integer_type_node)
15861     return long_unsigned_type_node;
15862   if (type1 == long_long_integer_type_node)
15863     return long_long_unsigned_type_node;
15864 #if 0   /* gcc/c-* files only */
15865   if (type1 == intDI_type_node)
15866     return unsigned_intDI_type_node;
15867   if (type1 == intSI_type_node)
15868     return unsigned_intSI_type_node;
15869   if (type1 == intHI_type_node)
15870     return unsigned_intHI_type_node;
15871   if (type1 == intQI_type_node)
15872     return unsigned_intQI_type_node;
15873 #endif
15874
15875   type2 = type_for_size (TYPE_PRECISION (type1), 1);
15876   if (type2 != NULL_TREE)
15877     return type2;
15878
15879   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15880     {
15881       type2 = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15882
15883       if (type1 == type2)
15884         return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15885     }
15886
15887   return type;
15888 }
15889
15890 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
15891 \f
15892 #if FFECOM_GCC_INCLUDE
15893
15894 /* From gcc/cccp.c, the code to handle -I.  */
15895
15896 /* Skip leading "./" from a directory name.
15897    This may yield the empty string, which represents the current directory.  */
15898
15899 static const char *
15900 skip_redundant_dir_prefix (const char *dir)
15901 {
15902   while (dir[0] == '.' && dir[1] == '/')
15903     for (dir += 2; *dir == '/'; dir++)
15904       continue;
15905   if (dir[0] == '.' && !dir[1])
15906     dir++;
15907   return dir;
15908 }
15909
15910 /* The file_name_map structure holds a mapping of file names for a
15911    particular directory.  This mapping is read from the file named
15912    FILE_NAME_MAP_FILE in that directory.  Such a file can be used to
15913    map filenames on a file system with severe filename restrictions,
15914    such as DOS.  The format of the file name map file is just a series
15915    of lines with two tokens on each line.  The first token is the name
15916    to map, and the second token is the actual name to use.  */
15917
15918 struct file_name_map
15919 {
15920   struct file_name_map *map_next;
15921   char *map_from;
15922   char *map_to;
15923 };
15924
15925 #define FILE_NAME_MAP_FILE "header.gcc"
15926
15927 /* Current maximum length of directory names in the search path
15928    for include files.  (Altered as we get more of them.)  */
15929
15930 static int max_include_len = 0;
15931
15932 struct file_name_list
15933   {
15934     struct file_name_list *next;
15935     char *fname;
15936     /* Mapping of file names for this directory.  */
15937     struct file_name_map *name_map;
15938     /* Non-zero if name_map is valid.  */
15939     int got_name_map;
15940   };
15941
15942 static struct file_name_list *include = NULL;   /* First dir to search */
15943 static struct file_name_list *last_include = NULL;      /* Last in chain */
15944
15945 /* I/O buffer structure.
15946    The `fname' field is nonzero for source files and #include files
15947    and for the dummy text used for -D and -U.
15948    It is zero for rescanning results of macro expansion
15949    and for expanding macro arguments.  */
15950 #define INPUT_STACK_MAX 400
15951 static struct file_buf {
15952   char *fname;
15953   /* Filename specified with #line command.  */
15954   char *nominal_fname;
15955   /* Record where in the search path this file was found.
15956      For #include_next.  */
15957   struct file_name_list *dir;
15958   ffewhereLine line;
15959   ffewhereColumn column;
15960 } instack[INPUT_STACK_MAX];
15961
15962 static int last_error_tick = 0;    /* Incremented each time we print it.  */
15963 static int input_file_stack_tick = 0;  /* Incremented when status changes.  */
15964
15965 /* Current nesting level of input sources.
15966    `instack[indepth]' is the level currently being read.  */
15967 static int indepth = -1;
15968
15969 typedef struct file_buf FILE_BUF;
15970
15971 typedef unsigned char U_CHAR;
15972
15973 /* table to tell if char can be part of a C identifier. */
15974 U_CHAR is_idchar[256];
15975 /* table to tell if char can be first char of a c identifier. */
15976 U_CHAR is_idstart[256];
15977 /* table to tell if c is horizontal space.  */
15978 U_CHAR is_hor_space[256];
15979 /* table to tell if c is horizontal or vertical space.  */
15980 static U_CHAR is_space[256];
15981
15982 #define SKIP_WHITE_SPACE(p) do { while (is_hor_space[*p]) p++; } while (0)
15983 #define SKIP_ALL_WHITE_SPACE(p) do { while (is_space[*p]) p++; } while (0)
15984
15985 /* Nonzero means -I- has been seen,
15986    so don't look for #include "foo" the source-file directory.  */
15987 static int ignore_srcdir;
15988
15989 #ifndef INCLUDE_LEN_FUDGE
15990 #define INCLUDE_LEN_FUDGE 0
15991 #endif
15992
15993 static void append_include_chain (struct file_name_list *first,
15994                                   struct file_name_list *last);
15995 static FILE *open_include_file (char *filename,
15996                                 struct file_name_list *searchptr);
15997 static void print_containing_files (ffebadSeverity sev);
15998 static const char *skip_redundant_dir_prefix (const char *);
15999 static char *read_filename_string (int ch, FILE *f);
16000 static struct file_name_map *read_name_map (const char *dirname);
16001
16002 /* Append a chain of `struct file_name_list's
16003    to the end of the main include chain.
16004    FIRST is the beginning of the chain to append, and LAST is the end.  */
16005
16006 static void
16007 append_include_chain (first, last)
16008      struct file_name_list *first, *last;
16009 {
16010   struct file_name_list *dir;
16011
16012   if (!first || !last)
16013     return;
16014
16015   if (include == 0)
16016     include = first;
16017   else
16018     last_include->next = first;
16019
16020   for (dir = first; ; dir = dir->next) {
16021     int len = strlen (dir->fname) + INCLUDE_LEN_FUDGE;
16022     if (len > max_include_len)
16023       max_include_len = len;
16024     if (dir == last)
16025       break;
16026   }
16027
16028   last->next = NULL;
16029   last_include = last;
16030 }
16031
16032 /* Try to open include file FILENAME.  SEARCHPTR is the directory
16033    being tried from the include file search path.  This function maps
16034    filenames on file systems based on information read by
16035    read_name_map.  */
16036
16037 static FILE *
16038 open_include_file (filename, searchptr)
16039      char *filename;
16040      struct file_name_list *searchptr;
16041 {
16042   register struct file_name_map *map;
16043   register char *from;
16044   char *p, *dir;
16045
16046   if (searchptr && ! searchptr->got_name_map)
16047     {
16048       searchptr->name_map = read_name_map (searchptr->fname
16049                                            ? searchptr->fname : ".");
16050       searchptr->got_name_map = 1;
16051     }
16052
16053   /* First check the mapping for the directory we are using.  */
16054   if (searchptr && searchptr->name_map)
16055     {
16056       from = filename;
16057       if (searchptr->fname)
16058         from += strlen (searchptr->fname) + 1;
16059       for (map = searchptr->name_map; map; map = map->map_next)
16060         {
16061           if (! strcmp (map->map_from, from))
16062             {
16063               /* Found a match.  */
16064               return fopen (map->map_to, "r");
16065             }
16066         }
16067     }
16068
16069   /* Try to find a mapping file for the particular directory we are
16070      looking in.  Thus #include <sys/types.h> will look up sys/types.h
16071      in /usr/include/header.gcc and look up types.h in
16072      /usr/include/sys/header.gcc.  */
16073   p = rindex (filename, '/');
16074 #ifdef DIR_SEPARATOR
16075   if (! p) p = rindex (filename, DIR_SEPARATOR);
16076   else {
16077     char *tmp = rindex (filename, DIR_SEPARATOR);
16078     if (tmp != NULL && tmp > p) p = tmp;
16079   }
16080 #endif
16081   if (! p)
16082     p = filename;
16083   if (searchptr
16084       && searchptr->fname
16085       && strlen (searchptr->fname) == (size_t) (p - filename)
16086       && ! strncmp (searchptr->fname, filename, (int) (p - filename)))
16087     {
16088       /* FILENAME is in SEARCHPTR, which we've already checked.  */
16089       return fopen (filename, "r");
16090     }
16091
16092   if (p == filename)
16093     {
16094       from = filename;
16095       map = read_name_map (".");
16096     }
16097   else
16098     {
16099       dir = (char *) xmalloc (p - filename + 1);
16100       memcpy (dir, filename, p - filename);
16101       dir[p - filename] = '\0';
16102       from = p + 1;
16103       map = read_name_map (dir);
16104       free (dir);
16105     }
16106   for (; map; map = map->map_next)
16107     if (! strcmp (map->map_from, from))
16108       return fopen (map->map_to, "r");
16109
16110   return fopen (filename, "r");
16111 }
16112
16113 /* Print the file names and line numbers of the #include
16114    commands which led to the current file.  */
16115
16116 static void
16117 print_containing_files (ffebadSeverity sev)
16118 {
16119   FILE_BUF *ip = NULL;
16120   int i;
16121   int first = 1;
16122   const char *str1;
16123   const char *str2;
16124
16125   /* If stack of files hasn't changed since we last printed
16126      this info, don't repeat it.  */
16127   if (last_error_tick == input_file_stack_tick)
16128     return;
16129
16130   for (i = indepth; i >= 0; i--)
16131     if (instack[i].fname != NULL) {
16132       ip = &instack[i];
16133       break;
16134     }
16135
16136   /* Give up if we don't find a source file.  */
16137   if (ip == NULL)
16138     return;
16139
16140   /* Find the other, outer source files.  */
16141   for (i--; i >= 0; i--)
16142     if (instack[i].fname != NULL)
16143       {
16144         ip = &instack[i];
16145         if (first)
16146           {
16147             first = 0;
16148             str1 = "In file included";
16149           }
16150         else
16151           {
16152             str1 = "...          ...";
16153           }
16154
16155         if (i == 1)
16156           str2 = ":";
16157         else
16158           str2 = "";
16159
16160         ffebad_start_msg ("%A from %B at %0%C", sev);
16161         ffebad_here (0, ip->line, ip->column);
16162         ffebad_string (str1);
16163         ffebad_string (ip->nominal_fname);
16164         ffebad_string (str2);
16165         ffebad_finish ();
16166       }
16167
16168   /* Record we have printed the status as of this time.  */
16169   last_error_tick = input_file_stack_tick;
16170 }
16171
16172 /* Read a space delimited string of unlimited length from a stdio
16173    file.  */
16174
16175 static char *
16176 read_filename_string (ch, f)
16177      int ch;
16178      FILE *f;
16179 {
16180   char *alloc, *set;
16181   int len;
16182
16183   len = 20;
16184   set = alloc = xmalloc (len + 1);
16185   if (! is_space[ch])
16186     {
16187       *set++ = ch;
16188       while ((ch = getc (f)) != EOF && ! is_space[ch])
16189         {
16190           if (set - alloc == len)
16191             {
16192               len *= 2;
16193               alloc = xrealloc (alloc, len + 1);
16194               set = alloc + len / 2;
16195             }
16196           *set++ = ch;
16197         }
16198     }
16199   *set = '\0';
16200   ungetc (ch, f);
16201   return alloc;
16202 }
16203
16204 /* Read the file name map file for DIRNAME.  */
16205
16206 static struct file_name_map *
16207 read_name_map (dirname)
16208      const char *dirname;
16209 {
16210   /* This structure holds a linked list of file name maps, one per
16211      directory.  */
16212   struct file_name_map_list
16213     {
16214       struct file_name_map_list *map_list_next;
16215       char *map_list_name;
16216       struct file_name_map *map_list_map;
16217     };
16218   static struct file_name_map_list *map_list;
16219   register struct file_name_map_list *map_list_ptr;
16220   char *name;
16221   FILE *f;
16222   size_t dirlen;
16223   int separator_needed;
16224
16225   dirname = skip_redundant_dir_prefix (dirname);
16226
16227   for (map_list_ptr = map_list; map_list_ptr;
16228        map_list_ptr = map_list_ptr->map_list_next)
16229     if (! strcmp (map_list_ptr->map_list_name, dirname))
16230       return map_list_ptr->map_list_map;
16231
16232   map_list_ptr = ((struct file_name_map_list *)
16233                   xmalloc (sizeof (struct file_name_map_list)));
16234   map_list_ptr->map_list_name = xstrdup (dirname);
16235   map_list_ptr->map_list_map = NULL;
16236
16237   dirlen = strlen (dirname);
16238   separator_needed = dirlen != 0 && dirname[dirlen - 1] != '/';
16239   name = (char *) xmalloc (dirlen + strlen (FILE_NAME_MAP_FILE) + 2);
16240   strcpy (name, dirname);
16241   name[dirlen] = '/';
16242   strcpy (name + dirlen + separator_needed, FILE_NAME_MAP_FILE);
16243   f = fopen (name, "r");
16244   free (name);
16245   if (!f)
16246     map_list_ptr->map_list_map = NULL;
16247   else
16248     {
16249       int ch;
16250
16251       while ((ch = getc (f)) != EOF)
16252         {
16253           char *from, *to;
16254           struct file_name_map *ptr;
16255
16256           if (is_space[ch])
16257             continue;
16258           from = read_filename_string (ch, f);
16259           while ((ch = getc (f)) != EOF && is_hor_space[ch])
16260             ;
16261           to = read_filename_string (ch, f);
16262
16263           ptr = ((struct file_name_map *)
16264                  xmalloc (sizeof (struct file_name_map)));
16265           ptr->map_from = from;
16266
16267           /* Make the real filename absolute.  */
16268           if (*to == '/')
16269             ptr->map_to = to;
16270           else
16271             {
16272               ptr->map_to = xmalloc (dirlen + strlen (to) + 2);
16273               strcpy (ptr->map_to, dirname);
16274               ptr->map_to[dirlen] = '/';
16275               strcpy (ptr->map_to + dirlen + separator_needed, to);
16276               free (to);
16277             }
16278
16279           ptr->map_next = map_list_ptr->map_list_map;
16280           map_list_ptr->map_list_map = ptr;
16281
16282           while ((ch = getc (f)) != '\n')
16283             if (ch == EOF)
16284               break;
16285         }
16286       fclose (f);
16287     }
16288
16289   map_list_ptr->map_list_next = map_list;
16290   map_list = map_list_ptr;
16291
16292   return map_list_ptr->map_list_map;
16293 }
16294
16295 static void
16296 ffecom_file_ (char *name)
16297 {
16298   FILE_BUF *fp;
16299
16300   /* Do partial setup of input buffer for the sake of generating
16301      early #line directives (when -g is in effect).  */
16302
16303   fp = &instack[++indepth];
16304   memset ((char *) fp, 0, sizeof (FILE_BUF));
16305   if (name == NULL)
16306     name = "";
16307   fp->nominal_fname = fp->fname = name;
16308 }
16309
16310 /* Initialize syntactic classifications of characters.  */
16311
16312 static void
16313 ffecom_initialize_char_syntax_ ()
16314 {
16315   register int i;
16316
16317   /*
16318    * Set up is_idchar and is_idstart tables.  These should be
16319    * faster than saying (is_alpha (c) || c == '_'), etc.
16320    * Set up these things before calling any routines tthat
16321    * refer to them.
16322    */
16323   for (i = 'a'; i <= 'z'; i++) {
16324     is_idchar[i - 'a' + 'A'] = 1;
16325     is_idchar[i] = 1;
16326     is_idstart[i - 'a' + 'A'] = 1;
16327     is_idstart[i] = 1;
16328   }
16329   for (i = '0'; i <= '9'; i++)
16330     is_idchar[i] = 1;
16331   is_idchar['_'] = 1;
16332   is_idstart['_'] = 1;
16333
16334   /* horizontal space table */
16335   is_hor_space[' '] = 1;
16336   is_hor_space['\t'] = 1;
16337   is_hor_space['\v'] = 1;
16338   is_hor_space['\f'] = 1;
16339   is_hor_space['\r'] = 1;
16340
16341   is_space[' '] = 1;
16342   is_space['\t'] = 1;
16343   is_space['\v'] = 1;
16344   is_space['\f'] = 1;
16345   is_space['\n'] = 1;
16346   is_space['\r'] = 1;
16347 }
16348
16349 static void
16350 ffecom_close_include_ (FILE *f)
16351 {
16352   fclose (f);
16353
16354   indepth--;
16355   input_file_stack_tick++;
16356
16357   ffewhere_line_kill (instack[indepth].line);
16358   ffewhere_column_kill (instack[indepth].column);
16359 }
16360
16361 static int
16362 ffecom_decode_include_option_ (char *spec)
16363 {
16364   struct file_name_list *dirtmp;
16365
16366   if (! ignore_srcdir && !strcmp (spec, "-"))
16367     ignore_srcdir = 1;
16368   else
16369     {
16370       dirtmp = (struct file_name_list *)
16371         xmalloc (sizeof (struct file_name_list));
16372       dirtmp->next = 0;         /* New one goes on the end */
16373       if (spec[0] != 0)
16374         dirtmp->fname = spec;
16375       else
16376         fatal ("Directory name must immediately follow -I option with no intervening spaces, as in `-Idir', not `-I dir'");
16377       dirtmp->got_name_map = 0;
16378       append_include_chain (dirtmp, dirtmp);
16379     }
16380   return 1;
16381 }
16382
16383 /* Open INCLUDEd file.  */
16384
16385 static FILE *
16386 ffecom_open_include_ (char *name, ffewhereLine l, ffewhereColumn c)
16387 {
16388   char *fbeg = name;
16389   size_t flen = strlen (fbeg);
16390   struct file_name_list *search_start = include; /* Chain of dirs to search */
16391   struct file_name_list dsp[1]; /* First in chain, if #include "..." */
16392   struct file_name_list *searchptr = 0;
16393   char *fname;          /* Dynamically allocated fname buffer */
16394   FILE *f;
16395   FILE_BUF *fp;
16396
16397   if (flen == 0)
16398     return NULL;
16399
16400   dsp[0].fname = NULL;
16401
16402   /* If -I- was specified, don't search current dir, only spec'd ones. */
16403   if (!ignore_srcdir)
16404     {
16405       for (fp = &instack[indepth]; fp >= instack; fp--)
16406         {
16407           int n;
16408           char *ep;
16409           char *nam;
16410
16411           if ((nam = fp->nominal_fname) != NULL)
16412             {
16413               /* Found a named file.  Figure out dir of the file,
16414                  and put it in front of the search list.  */
16415               dsp[0].next = search_start;
16416               search_start = dsp;
16417 #ifndef VMS
16418               ep = rindex (nam, '/');
16419 #ifdef DIR_SEPARATOR
16420             if (ep == NULL) ep = rindex (nam, DIR_SEPARATOR);
16421             else {
16422               char *tmp = rindex (nam, DIR_SEPARATOR);
16423               if (tmp != NULL && tmp > ep) ep = tmp;
16424             }
16425 #endif
16426 #else                           /* VMS */
16427               ep = rindex (nam, ']');
16428               if (ep == NULL) ep = rindex (nam, '>');
16429               if (ep == NULL) ep = rindex (nam, ':');
16430               if (ep != NULL) ep++;
16431 #endif                          /* VMS */
16432               if (ep != NULL)
16433                 {
16434                   n = ep - nam;
16435                   dsp[0].fname = (char *) xmalloc (n + 1);
16436                   strncpy (dsp[0].fname, nam, n);
16437                   dsp[0].fname[n] = '\0';
16438                   if (n + INCLUDE_LEN_FUDGE > max_include_len)
16439                     max_include_len = n + INCLUDE_LEN_FUDGE;
16440                 }
16441               else
16442                 dsp[0].fname = NULL; /* Current directory */
16443               dsp[0].got_name_map = 0;
16444               break;
16445             }
16446         }
16447     }
16448
16449   /* Allocate this permanently, because it gets stored in the definitions
16450      of macros.  */
16451   fname = xmalloc (max_include_len + flen + 4);
16452   /* + 2 above for slash and terminating null.  */
16453   /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
16454      for g77 yet).  */
16455
16456   /* If specified file name is absolute, just open it.  */
16457
16458   if (*fbeg == '/'
16459 #ifdef DIR_SEPARATOR
16460       || *fbeg == DIR_SEPARATOR
16461 #endif
16462       )
16463     {
16464       strncpy (fname, (char *) fbeg, flen);
16465       fname[flen] = 0;
16466       f = open_include_file (fname, NULL_PTR);
16467     }
16468   else
16469     {
16470       f = NULL;
16471
16472       /* Search directory path, trying to open the file.
16473          Copy each filename tried into FNAME.  */
16474
16475       for (searchptr = search_start; searchptr; searchptr = searchptr->next)
16476         {
16477           if (searchptr->fname)
16478             {
16479               /* The empty string in a search path is ignored.
16480                  This makes it possible to turn off entirely
16481                  a standard piece of the list.  */
16482               if (searchptr->fname[0] == 0)
16483                 continue;
16484               strcpy (fname, skip_redundant_dir_prefix (searchptr->fname));
16485               if (fname[0] && fname[strlen (fname) - 1] != '/')
16486                 strcat (fname, "/");
16487               fname[strlen (fname) + flen] = 0;
16488             }
16489           else
16490             fname[0] = 0;
16491
16492           strncat (fname, fbeg, flen);
16493 #ifdef VMS
16494           /* Change this 1/2 Unix 1/2 VMS file specification into a
16495              full VMS file specification */
16496           if (searchptr->fname && (searchptr->fname[0] != 0))
16497             {
16498               /* Fix up the filename */
16499               hack_vms_include_specification (fname);
16500             }
16501           else
16502             {
16503               /* This is a normal VMS filespec, so use it unchanged.  */
16504               strncpy (fname, (char *) fbeg, flen);
16505               fname[flen] = 0;
16506 #if 0   /* Not for g77.  */
16507               /* if it's '#include filename', add the missing .h */
16508               if (index (fname, '.') == NULL)
16509                 strcat (fname, ".h");
16510 #endif
16511             }
16512 #endif /* VMS */
16513           f = open_include_file (fname, searchptr);
16514 #ifdef EACCES
16515           if (f == NULL && errno == EACCES)
16516             {
16517               print_containing_files (FFEBAD_severityWARNING);
16518               ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
16519                                 FFEBAD_severityWARNING);
16520               ffebad_string (fname);
16521               ffebad_here (0, l, c);
16522               ffebad_finish ();
16523             }
16524 #endif
16525           if (f != NULL)
16526             break;
16527         }
16528     }
16529
16530   if (f == NULL)
16531     {
16532       /* A file that was not found.  */
16533
16534       strncpy (fname, (char *) fbeg, flen);
16535       fname[flen] = 0;
16536       print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE));
16537       ffebad_start (FFEBAD_OPEN_INCLUDE);
16538       ffebad_here (0, l, c);
16539       ffebad_string (fname);
16540       ffebad_finish ();
16541     }
16542
16543   if (dsp[0].fname != NULL)
16544     free (dsp[0].fname);
16545
16546   if (f == NULL)
16547     return NULL;
16548
16549   if (indepth >= (INPUT_STACK_MAX - 1))
16550     {
16551       print_containing_files (FFEBAD_severityFATAL);
16552       ffebad_start_msg ("At %0, INCLUDE nesting too deep",
16553                         FFEBAD_severityFATAL);
16554       ffebad_string (fname);
16555       ffebad_here (0, l, c);
16556       ffebad_finish ();
16557       return NULL;
16558     }
16559
16560   instack[indepth].line = ffewhere_line_use (l);
16561   instack[indepth].column = ffewhere_column_use (c);
16562
16563   fp = &instack[indepth + 1];
16564   memset ((char *) fp, 0, sizeof (FILE_BUF));
16565   fp->nominal_fname = fp->fname = fname;
16566   fp->dir = searchptr;
16567
16568   indepth++;
16569   input_file_stack_tick++;
16570
16571   return f;
16572 }
16573 #endif  /* FFECOM_GCC_INCLUDE */
16574
16575 /**INDENT* (Do not reformat this comment even with -fca option.)
16576    Data-gathering files: Given the source file listed below, compiled with
16577    f2c I obtained the output file listed after that, and from the output
16578    file I derived the above code.
16579
16580 -------- (begin input file to f2c)
16581         implicit none
16582         character*10 A1,A2
16583         complex C1,C2
16584         integer I1,I2
16585         real R1,R2
16586         double precision D1,D2
16587 C
16588         call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
16589 c /
16590         call fooI(I1/I2)
16591         call fooR(R1/I1)
16592         call fooD(D1/I1)
16593         call fooC(C1/I1)
16594         call fooR(R1/R2)
16595         call fooD(R1/D1)
16596         call fooD(D1/D2)
16597         call fooD(D1/R1)
16598         call fooC(C1/C2)
16599         call fooC(C1/R1)
16600         call fooZ(C1/D1)
16601 c **
16602         call fooI(I1**I2)
16603         call fooR(R1**I1)
16604         call fooD(D1**I1)
16605         call fooC(C1**I1)
16606         call fooR(R1**R2)
16607         call fooD(R1**D1)
16608         call fooD(D1**D2)
16609         call fooD(D1**R1)
16610         call fooC(C1**C2)
16611         call fooC(C1**R1)
16612         call fooZ(C1**D1)
16613 c FFEINTRIN_impABS
16614         call fooR(ABS(R1))
16615 c FFEINTRIN_impACOS
16616         call fooR(ACOS(R1))
16617 c FFEINTRIN_impAIMAG
16618         call fooR(AIMAG(C1))
16619 c FFEINTRIN_impAINT
16620         call fooR(AINT(R1))
16621 c FFEINTRIN_impALOG
16622         call fooR(ALOG(R1))
16623 c FFEINTRIN_impALOG10
16624         call fooR(ALOG10(R1))
16625 c FFEINTRIN_impAMAX0
16626         call fooR(AMAX0(I1,I2))
16627 c FFEINTRIN_impAMAX1
16628         call fooR(AMAX1(R1,R2))
16629 c FFEINTRIN_impAMIN0
16630         call fooR(AMIN0(I1,I2))
16631 c FFEINTRIN_impAMIN1
16632         call fooR(AMIN1(R1,R2))
16633 c FFEINTRIN_impAMOD
16634         call fooR(AMOD(R1,R2))
16635 c FFEINTRIN_impANINT
16636         call fooR(ANINT(R1))
16637 c FFEINTRIN_impASIN
16638         call fooR(ASIN(R1))
16639 c FFEINTRIN_impATAN
16640         call fooR(ATAN(R1))
16641 c FFEINTRIN_impATAN2
16642         call fooR(ATAN2(R1,R2))
16643 c FFEINTRIN_impCABS
16644         call fooR(CABS(C1))
16645 c FFEINTRIN_impCCOS
16646         call fooC(CCOS(C1))
16647 c FFEINTRIN_impCEXP
16648         call fooC(CEXP(C1))
16649 c FFEINTRIN_impCHAR
16650         call fooA(CHAR(I1))
16651 c FFEINTRIN_impCLOG
16652         call fooC(CLOG(C1))
16653 c FFEINTRIN_impCONJG
16654         call fooC(CONJG(C1))
16655 c FFEINTRIN_impCOS
16656         call fooR(COS(R1))
16657 c FFEINTRIN_impCOSH
16658         call fooR(COSH(R1))
16659 c FFEINTRIN_impCSIN
16660         call fooC(CSIN(C1))
16661 c FFEINTRIN_impCSQRT
16662         call fooC(CSQRT(C1))
16663 c FFEINTRIN_impDABS
16664         call fooD(DABS(D1))
16665 c FFEINTRIN_impDACOS
16666         call fooD(DACOS(D1))
16667 c FFEINTRIN_impDASIN
16668         call fooD(DASIN(D1))
16669 c FFEINTRIN_impDATAN
16670         call fooD(DATAN(D1))
16671 c FFEINTRIN_impDATAN2
16672         call fooD(DATAN2(D1,D2))
16673 c FFEINTRIN_impDCOS
16674         call fooD(DCOS(D1))
16675 c FFEINTRIN_impDCOSH
16676         call fooD(DCOSH(D1))
16677 c FFEINTRIN_impDDIM
16678         call fooD(DDIM(D1,D2))
16679 c FFEINTRIN_impDEXP
16680         call fooD(DEXP(D1))
16681 c FFEINTRIN_impDIM
16682         call fooR(DIM(R1,R2))
16683 c FFEINTRIN_impDINT
16684         call fooD(DINT(D1))
16685 c FFEINTRIN_impDLOG
16686         call fooD(DLOG(D1))
16687 c FFEINTRIN_impDLOG10
16688         call fooD(DLOG10(D1))
16689 c FFEINTRIN_impDMAX1
16690         call fooD(DMAX1(D1,D2))
16691 c FFEINTRIN_impDMIN1
16692         call fooD(DMIN1(D1,D2))
16693 c FFEINTRIN_impDMOD
16694         call fooD(DMOD(D1,D2))
16695 c FFEINTRIN_impDNINT
16696         call fooD(DNINT(D1))
16697 c FFEINTRIN_impDPROD
16698         call fooD(DPROD(R1,R2))
16699 c FFEINTRIN_impDSIGN
16700         call fooD(DSIGN(D1,D2))
16701 c FFEINTRIN_impDSIN
16702         call fooD(DSIN(D1))
16703 c FFEINTRIN_impDSINH
16704         call fooD(DSINH(D1))
16705 c FFEINTRIN_impDSQRT
16706         call fooD(DSQRT(D1))
16707 c FFEINTRIN_impDTAN
16708         call fooD(DTAN(D1))
16709 c FFEINTRIN_impDTANH
16710         call fooD(DTANH(D1))
16711 c FFEINTRIN_impEXP
16712         call fooR(EXP(R1))
16713 c FFEINTRIN_impIABS
16714         call fooI(IABS(I1))
16715 c FFEINTRIN_impICHAR
16716         call fooI(ICHAR(A1))
16717 c FFEINTRIN_impIDIM
16718         call fooI(IDIM(I1,I2))
16719 c FFEINTRIN_impIDNINT
16720         call fooI(IDNINT(D1))
16721 c FFEINTRIN_impINDEX
16722         call fooI(INDEX(A1,A2))
16723 c FFEINTRIN_impISIGN
16724         call fooI(ISIGN(I1,I2))
16725 c FFEINTRIN_impLEN
16726         call fooI(LEN(A1))
16727 c FFEINTRIN_impLGE
16728         call fooL(LGE(A1,A2))
16729 c FFEINTRIN_impLGT
16730         call fooL(LGT(A1,A2))
16731 c FFEINTRIN_impLLE
16732         call fooL(LLE(A1,A2))
16733 c FFEINTRIN_impLLT
16734         call fooL(LLT(A1,A2))
16735 c FFEINTRIN_impMAX0
16736         call fooI(MAX0(I1,I2))
16737 c FFEINTRIN_impMAX1
16738         call fooI(MAX1(R1,R2))
16739 c FFEINTRIN_impMIN0
16740         call fooI(MIN0(I1,I2))
16741 c FFEINTRIN_impMIN1
16742         call fooI(MIN1(R1,R2))
16743 c FFEINTRIN_impMOD
16744         call fooI(MOD(I1,I2))
16745 c FFEINTRIN_impNINT
16746         call fooI(NINT(R1))
16747 c FFEINTRIN_impSIGN
16748         call fooR(SIGN(R1,R2))
16749 c FFEINTRIN_impSIN
16750         call fooR(SIN(R1))
16751 c FFEINTRIN_impSINH
16752         call fooR(SINH(R1))
16753 c FFEINTRIN_impSQRT
16754         call fooR(SQRT(R1))
16755 c FFEINTRIN_impTAN
16756         call fooR(TAN(R1))
16757 c FFEINTRIN_impTANH
16758         call fooR(TANH(R1))
16759 c FFEINTRIN_imp_CMPLX_C
16760         call fooC(cmplx(C1,C2))
16761 c FFEINTRIN_imp_CMPLX_D
16762         call fooZ(cmplx(D1,D2))
16763 c FFEINTRIN_imp_CMPLX_I
16764         call fooC(cmplx(I1,I2))
16765 c FFEINTRIN_imp_CMPLX_R
16766         call fooC(cmplx(R1,R2))
16767 c FFEINTRIN_imp_DBLE_C
16768         call fooD(dble(C1))
16769 c FFEINTRIN_imp_DBLE_D
16770         call fooD(dble(D1))
16771 c FFEINTRIN_imp_DBLE_I
16772         call fooD(dble(I1))
16773 c FFEINTRIN_imp_DBLE_R
16774         call fooD(dble(R1))
16775 c FFEINTRIN_imp_INT_C
16776         call fooI(int(C1))
16777 c FFEINTRIN_imp_INT_D
16778         call fooI(int(D1))
16779 c FFEINTRIN_imp_INT_I
16780         call fooI(int(I1))
16781 c FFEINTRIN_imp_INT_R
16782         call fooI(int(R1))
16783 c FFEINTRIN_imp_REAL_C
16784         call fooR(real(C1))
16785 c FFEINTRIN_imp_REAL_D
16786         call fooR(real(D1))
16787 c FFEINTRIN_imp_REAL_I
16788         call fooR(real(I1))
16789 c FFEINTRIN_imp_REAL_R
16790         call fooR(real(R1))
16791 c
16792 c FFEINTRIN_imp_INT_D:
16793 c
16794 c FFEINTRIN_specIDINT
16795         call fooI(IDINT(D1))
16796 c
16797 c FFEINTRIN_imp_INT_R:
16798 c
16799 c FFEINTRIN_specIFIX
16800         call fooI(IFIX(R1))
16801 c FFEINTRIN_specINT
16802         call fooI(INT(R1))
16803 c
16804 c FFEINTRIN_imp_REAL_D:
16805 c
16806 c FFEINTRIN_specSNGL
16807         call fooR(SNGL(D1))
16808 c
16809 c FFEINTRIN_imp_REAL_I:
16810 c
16811 c FFEINTRIN_specFLOAT
16812         call fooR(FLOAT(I1))
16813 c FFEINTRIN_specREAL
16814         call fooR(REAL(I1))
16815 c
16816         end
16817 -------- (end input file to f2c)
16818
16819 -------- (begin output from providing above input file as input to:
16820 --------  `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
16821 --------     -e "s:^#.*$::g"')
16822
16823 //  -- translated by f2c (version 19950223).
16824    You must link the resulting object file with the libraries:
16825         -lf2c -lm   (in that order)
16826 //
16827
16828
16829 // f2c.h  --  Standard Fortran to C header file //
16830
16831 ///  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
16832
16833         - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
16834
16835
16836
16837
16838 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
16839 // we assume short, float are OK //
16840 typedef long int // long int // integer;
16841 typedef char *address;
16842 typedef short int shortint;
16843 typedef float real;
16844 typedef double doublereal;
16845 typedef struct { real r, i; } complex;
16846 typedef struct { doublereal r, i; } doublecomplex;
16847 typedef long int // long int // logical;
16848 typedef short int shortlogical;
16849 typedef char logical1;
16850 typedef char integer1;
16851 // typedef long long longint; // // system-dependent //
16852
16853
16854
16855
16856 // Extern is for use with -E //
16857
16858
16859
16860
16861 // I/O stuff //
16862
16863
16864
16865
16866
16867
16868
16869
16870 typedef long int // int or long int // flag;
16871 typedef long int // int or long int // ftnlen;
16872 typedef long int // int or long int // ftnint;
16873
16874
16875 //external read, write//
16876 typedef struct
16877 {       flag cierr;
16878         ftnint ciunit;
16879         flag ciend;
16880         char *cifmt;
16881         ftnint cirec;
16882 } cilist;
16883
16884 //internal read, write//
16885 typedef struct
16886 {       flag icierr;
16887         char *iciunit;
16888         flag iciend;
16889         char *icifmt;
16890         ftnint icirlen;
16891         ftnint icirnum;
16892 } icilist;
16893
16894 //open//
16895 typedef struct
16896 {       flag oerr;
16897         ftnint ounit;
16898         char *ofnm;
16899         ftnlen ofnmlen;
16900         char *osta;
16901         char *oacc;
16902         char *ofm;
16903         ftnint orl;
16904         char *oblnk;
16905 } olist;
16906
16907 //close//
16908 typedef struct
16909 {       flag cerr;
16910         ftnint cunit;
16911         char *csta;
16912 } cllist;
16913
16914 //rewind, backspace, endfile//
16915 typedef struct
16916 {       flag aerr;
16917         ftnint aunit;
16918 } alist;
16919
16920 // inquire //
16921 typedef struct
16922 {       flag inerr;
16923         ftnint inunit;
16924         char *infile;
16925         ftnlen infilen;
16926         ftnint  *inex;  //parameters in standard's order//
16927         ftnint  *inopen;
16928         ftnint  *innum;
16929         ftnint  *innamed;
16930         char    *inname;
16931         ftnlen  innamlen;
16932         char    *inacc;
16933         ftnlen  inacclen;
16934         char    *inseq;
16935         ftnlen  inseqlen;
16936         char    *indir;
16937         ftnlen  indirlen;
16938         char    *infmt;
16939         ftnlen  infmtlen;
16940         char    *inform;
16941         ftnint  informlen;
16942         char    *inunf;
16943         ftnlen  inunflen;
16944         ftnint  *inrecl;
16945         ftnint  *innrec;
16946         char    *inblank;
16947         ftnlen  inblanklen;
16948 } inlist;
16949
16950
16951
16952 union Multitype {       // for multiple entry points //
16953         integer1 g;
16954         shortint h;
16955         integer i;
16956         // longint j; //
16957         real r;
16958         doublereal d;
16959         complex c;
16960         doublecomplex z;
16961         };
16962
16963 typedef union Multitype Multitype;
16964
16965 typedef long Long;      // No longer used; formerly in Namelist //
16966
16967 struct Vardesc {        // for Namelist //
16968         char *name;
16969         char *addr;
16970         ftnlen *dims;
16971         int  type;
16972         };
16973 typedef struct Vardesc Vardesc;
16974
16975 struct Namelist {
16976         char *name;
16977         Vardesc **vars;
16978         int nvars;
16979         };
16980 typedef struct Namelist Namelist;
16981
16982
16983
16984
16985
16986
16987
16988
16989 // procedure parameter types for -A and -C++ //
16990
16991
16992
16993
16994 typedef int // Unknown procedure type // (*U_fp)();
16995 typedef shortint (*J_fp)();
16996 typedef integer (*I_fp)();
16997 typedef real (*R_fp)();
16998 typedef doublereal (*D_fp)(), (*E_fp)();
16999 typedef // Complex // void  (*C_fp)();
17000 typedef // Double Complex // void  (*Z_fp)();
17001 typedef logical (*L_fp)();
17002 typedef shortlogical (*K_fp)();
17003 typedef // Character // void  (*H_fp)();
17004 typedef // Subroutine // int (*S_fp)();
17005
17006 // E_fp is for real functions when -R is not specified //
17007 typedef void  C_f;      // complex function //
17008 typedef void  H_f;      // character function //
17009 typedef void  Z_f;      // double complex function //
17010 typedef doublereal E_f; // real function with -R not specified //
17011
17012 // undef any lower-case symbols that your C compiler predefines, e.g.: //
17013
17014
17015 // (No such symbols should be defined in a strict ANSI C compiler.
17016    We can avoid trouble with f2c-translated code by using
17017    gcc -ansi [-traditional].) //
17018
17019
17020
17021
17022
17023
17024
17025
17026
17027
17028
17029
17030
17031
17032
17033
17034
17035
17036
17037
17038
17039
17040
17041 // Main program // MAIN__()
17042 {
17043     // System generated locals //
17044     integer i__1;
17045     real r__1, r__2;
17046     doublereal d__1, d__2;
17047     complex q__1;
17048     doublecomplex z__1, z__2, z__3;
17049     logical L__1;
17050     char ch__1[1];
17051
17052     // Builtin functions //
17053     void c_div();
17054     integer pow_ii();
17055     double pow_ri(), pow_di();
17056     void pow_ci();
17057     double pow_dd();
17058     void pow_zz();
17059     double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
17060             asin(), atan(), atan2(), c_abs();
17061     void c_cos(), c_exp(), c_log(), r_cnjg();
17062     double cos(), cosh();
17063     void c_sin(), c_sqrt();
17064     double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
17065             d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
17066     integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
17067     logical l_ge(), l_gt(), l_le(), l_lt();
17068     integer i_nint();
17069     double r_sign();
17070
17071     // Local variables //
17072     extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
17073             fool_(), fooz_(), getem_();
17074     static char a1[10], a2[10];
17075     static complex c1, c2;
17076     static doublereal d1, d2;
17077     static integer i1, i2;
17078     static real r1, r2;
17079
17080
17081     getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
17082 // / //
17083     i__1 = i1 / i2;
17084     fooi_(&i__1);
17085     r__1 = r1 / i1;
17086     foor_(&r__1);
17087     d__1 = d1 / i1;
17088     food_(&d__1);
17089     d__1 = (doublereal) i1;
17090     q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
17091     fooc_(&q__1);
17092     r__1 = r1 / r2;
17093     foor_(&r__1);
17094     d__1 = r1 / d1;
17095     food_(&d__1);
17096     d__1 = d1 / d2;
17097     food_(&d__1);
17098     d__1 = d1 / r1;
17099     food_(&d__1);
17100     c_div(&q__1, &c1, &c2);
17101     fooc_(&q__1);
17102     q__1.r = c1.r / r1, q__1.i = c1.i / r1;
17103     fooc_(&q__1);
17104     z__1.r = c1.r / d1, z__1.i = c1.i / d1;
17105     fooz_(&z__1);
17106 // ** //
17107     i__1 = pow_ii(&i1, &i2);
17108     fooi_(&i__1);
17109     r__1 = pow_ri(&r1, &i1);
17110     foor_(&r__1);
17111     d__1 = pow_di(&d1, &i1);
17112     food_(&d__1);
17113     pow_ci(&q__1, &c1, &i1);
17114     fooc_(&q__1);
17115     d__1 = (doublereal) r1;
17116     d__2 = (doublereal) r2;
17117     r__1 = pow_dd(&d__1, &d__2);
17118     foor_(&r__1);
17119     d__2 = (doublereal) r1;
17120     d__1 = pow_dd(&d__2, &d1);
17121     food_(&d__1);
17122     d__1 = pow_dd(&d1, &d2);
17123     food_(&d__1);
17124     d__2 = (doublereal) r1;
17125     d__1 = pow_dd(&d1, &d__2);
17126     food_(&d__1);
17127     z__2.r = c1.r, z__2.i = c1.i;
17128     z__3.r = c2.r, z__3.i = c2.i;
17129     pow_zz(&z__1, &z__2, &z__3);
17130     q__1.r = z__1.r, q__1.i = z__1.i;
17131     fooc_(&q__1);
17132     z__2.r = c1.r, z__2.i = c1.i;
17133     z__3.r = r1, z__3.i = 0.;
17134     pow_zz(&z__1, &z__2, &z__3);
17135     q__1.r = z__1.r, q__1.i = z__1.i;
17136     fooc_(&q__1);
17137     z__2.r = c1.r, z__2.i = c1.i;
17138     z__3.r = d1, z__3.i = 0.;
17139     pow_zz(&z__1, &z__2, &z__3);
17140     fooz_(&z__1);
17141 // FFEINTRIN_impABS //
17142     r__1 = (doublereal)((  r1  ) >= 0 ? (  r1  ) : -(  r1  ))  ;
17143     foor_(&r__1);
17144 // FFEINTRIN_impACOS //
17145     r__1 = acos(r1);
17146     foor_(&r__1);
17147 // FFEINTRIN_impAIMAG //
17148     r__1 = r_imag(&c1);
17149     foor_(&r__1);
17150 // FFEINTRIN_impAINT //
17151     r__1 = r_int(&r1);
17152     foor_(&r__1);
17153 // FFEINTRIN_impALOG //
17154     r__1 = log(r1);
17155     foor_(&r__1);
17156 // FFEINTRIN_impALOG10 //
17157     r__1 = r_lg10(&r1);
17158     foor_(&r__1);
17159 // FFEINTRIN_impAMAX0 //
17160     r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
17161     foor_(&r__1);
17162 // FFEINTRIN_impAMAX1 //
17163     r__1 = (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
17164     foor_(&r__1);
17165 // FFEINTRIN_impAMIN0 //
17166     r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
17167     foor_(&r__1);
17168 // FFEINTRIN_impAMIN1 //
17169     r__1 = (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
17170     foor_(&r__1);
17171 // FFEINTRIN_impAMOD //
17172     r__1 = r_mod(&r1, &r2);
17173     foor_(&r__1);
17174 // FFEINTRIN_impANINT //
17175     r__1 = r_nint(&r1);
17176     foor_(&r__1);
17177 // FFEINTRIN_impASIN //
17178     r__1 = asin(r1);
17179     foor_(&r__1);
17180 // FFEINTRIN_impATAN //
17181     r__1 = atan(r1);
17182     foor_(&r__1);
17183 // FFEINTRIN_impATAN2 //
17184     r__1 = atan2(r1, r2);
17185     foor_(&r__1);
17186 // FFEINTRIN_impCABS //
17187     r__1 = c_abs(&c1);
17188     foor_(&r__1);
17189 // FFEINTRIN_impCCOS //
17190     c_cos(&q__1, &c1);
17191     fooc_(&q__1);
17192 // FFEINTRIN_impCEXP //
17193     c_exp(&q__1, &c1);
17194     fooc_(&q__1);
17195 // FFEINTRIN_impCHAR //
17196     *(unsigned char *)&ch__1[0] = i1;
17197     fooa_(ch__1, 1L);
17198 // FFEINTRIN_impCLOG //
17199     c_log(&q__1, &c1);
17200     fooc_(&q__1);
17201 // FFEINTRIN_impCONJG //
17202     r_cnjg(&q__1, &c1);
17203     fooc_(&q__1);
17204 // FFEINTRIN_impCOS //
17205     r__1 = cos(r1);
17206     foor_(&r__1);
17207 // FFEINTRIN_impCOSH //
17208     r__1 = cosh(r1);
17209     foor_(&r__1);
17210 // FFEINTRIN_impCSIN //
17211     c_sin(&q__1, &c1);
17212     fooc_(&q__1);
17213 // FFEINTRIN_impCSQRT //
17214     c_sqrt(&q__1, &c1);
17215     fooc_(&q__1);
17216 // FFEINTRIN_impDABS //
17217     d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
17218     food_(&d__1);
17219 // FFEINTRIN_impDACOS //
17220     d__1 = acos(d1);
17221     food_(&d__1);
17222 // FFEINTRIN_impDASIN //
17223     d__1 = asin(d1);
17224     food_(&d__1);
17225 // FFEINTRIN_impDATAN //
17226     d__1 = atan(d1);
17227     food_(&d__1);
17228 // FFEINTRIN_impDATAN2 //
17229     d__1 = atan2(d1, d2);
17230     food_(&d__1);
17231 // FFEINTRIN_impDCOS //
17232     d__1 = cos(d1);
17233     food_(&d__1);
17234 // FFEINTRIN_impDCOSH //
17235     d__1 = cosh(d1);
17236     food_(&d__1);
17237 // FFEINTRIN_impDDIM //
17238     d__1 = d_dim(&d1, &d2);
17239     food_(&d__1);
17240 // FFEINTRIN_impDEXP //
17241     d__1 = exp(d1);
17242     food_(&d__1);
17243 // FFEINTRIN_impDIM //
17244     r__1 = r_dim(&r1, &r2);
17245     foor_(&r__1);
17246 // FFEINTRIN_impDINT //
17247     d__1 = d_int(&d1);
17248     food_(&d__1);
17249 // FFEINTRIN_impDLOG //
17250     d__1 = log(d1);
17251     food_(&d__1);
17252 // FFEINTRIN_impDLOG10 //
17253     d__1 = d_lg10(&d1);
17254     food_(&d__1);
17255 // FFEINTRIN_impDMAX1 //
17256     d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
17257     food_(&d__1);
17258 // FFEINTRIN_impDMIN1 //
17259     d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
17260     food_(&d__1);
17261 // FFEINTRIN_impDMOD //
17262     d__1 = d_mod(&d1, &d2);
17263     food_(&d__1);
17264 // FFEINTRIN_impDNINT //
17265     d__1 = d_nint(&d1);
17266     food_(&d__1);
17267 // FFEINTRIN_impDPROD //
17268     d__1 = (doublereal) r1 * r2;
17269     food_(&d__1);
17270 // FFEINTRIN_impDSIGN //
17271     d__1 = d_sign(&d1, &d2);
17272     food_(&d__1);
17273 // FFEINTRIN_impDSIN //
17274     d__1 = sin(d1);
17275     food_(&d__1);
17276 // FFEINTRIN_impDSINH //
17277     d__1 = sinh(d1);
17278     food_(&d__1);
17279 // FFEINTRIN_impDSQRT //
17280     d__1 = sqrt(d1);
17281     food_(&d__1);
17282 // FFEINTRIN_impDTAN //
17283     d__1 = tan(d1);
17284     food_(&d__1);
17285 // FFEINTRIN_impDTANH //
17286     d__1 = tanh(d1);
17287     food_(&d__1);
17288 // FFEINTRIN_impEXP //
17289     r__1 = exp(r1);
17290     foor_(&r__1);
17291 // FFEINTRIN_impIABS //
17292     i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
17293     fooi_(&i__1);
17294 // FFEINTRIN_impICHAR //
17295     i__1 = *(unsigned char *)a1;
17296     fooi_(&i__1);
17297 // FFEINTRIN_impIDIM //
17298     i__1 = i_dim(&i1, &i2);
17299     fooi_(&i__1);
17300 // FFEINTRIN_impIDNINT //
17301     i__1 = i_dnnt(&d1);
17302     fooi_(&i__1);
17303 // FFEINTRIN_impINDEX //
17304     i__1 = i_indx(a1, a2, 10L, 10L);
17305     fooi_(&i__1);
17306 // FFEINTRIN_impISIGN //
17307     i__1 = i_sign(&i1, &i2);
17308     fooi_(&i__1);
17309 // FFEINTRIN_impLEN //
17310     i__1 = i_len(a1, 10L);
17311     fooi_(&i__1);
17312 // FFEINTRIN_impLGE //
17313     L__1 = l_ge(a1, a2, 10L, 10L);
17314     fool_(&L__1);
17315 // FFEINTRIN_impLGT //
17316     L__1 = l_gt(a1, a2, 10L, 10L);
17317     fool_(&L__1);
17318 // FFEINTRIN_impLLE //
17319     L__1 = l_le(a1, a2, 10L, 10L);
17320     fool_(&L__1);
17321 // FFEINTRIN_impLLT //
17322     L__1 = l_lt(a1, a2, 10L, 10L);
17323     fool_(&L__1);
17324 // FFEINTRIN_impMAX0 //
17325     i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
17326     fooi_(&i__1);
17327 // FFEINTRIN_impMAX1 //
17328     i__1 = (integer) (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
17329     fooi_(&i__1);
17330 // FFEINTRIN_impMIN0 //
17331     i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
17332     fooi_(&i__1);
17333 // FFEINTRIN_impMIN1 //
17334     i__1 = (integer) (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
17335     fooi_(&i__1);
17336 // FFEINTRIN_impMOD //
17337     i__1 = i1 % i2;
17338     fooi_(&i__1);
17339 // FFEINTRIN_impNINT //
17340     i__1 = i_nint(&r1);
17341     fooi_(&i__1);
17342 // FFEINTRIN_impSIGN //
17343     r__1 = r_sign(&r1, &r2);
17344     foor_(&r__1);
17345 // FFEINTRIN_impSIN //
17346     r__1 = sin(r1);
17347     foor_(&r__1);
17348 // FFEINTRIN_impSINH //
17349     r__1 = sinh(r1);
17350     foor_(&r__1);
17351 // FFEINTRIN_impSQRT //
17352     r__1 = sqrt(r1);
17353     foor_(&r__1);
17354 // FFEINTRIN_impTAN //
17355     r__1 = tan(r1);
17356     foor_(&r__1);
17357 // FFEINTRIN_impTANH //
17358     r__1 = tanh(r1);
17359     foor_(&r__1);
17360 // FFEINTRIN_imp_CMPLX_C //
17361     r__1 = c1.r;
17362     r__2 = c2.r;
17363     q__1.r = r__1, q__1.i = r__2;
17364     fooc_(&q__1);
17365 // FFEINTRIN_imp_CMPLX_D //
17366     z__1.r = d1, z__1.i = d2;
17367     fooz_(&z__1);
17368 // FFEINTRIN_imp_CMPLX_I //
17369     r__1 = (real) i1;
17370     r__2 = (real) i2;
17371     q__1.r = r__1, q__1.i = r__2;
17372     fooc_(&q__1);
17373 // FFEINTRIN_imp_CMPLX_R //
17374     q__1.r = r1, q__1.i = r2;
17375     fooc_(&q__1);
17376 // FFEINTRIN_imp_DBLE_C //
17377     d__1 = (doublereal) c1.r;
17378     food_(&d__1);
17379 // FFEINTRIN_imp_DBLE_D //
17380     d__1 = d1;
17381     food_(&d__1);
17382 // FFEINTRIN_imp_DBLE_I //
17383     d__1 = (doublereal) i1;
17384     food_(&d__1);
17385 // FFEINTRIN_imp_DBLE_R //
17386     d__1 = (doublereal) r1;
17387     food_(&d__1);
17388 // FFEINTRIN_imp_INT_C //
17389     i__1 = (integer) c1.r;
17390     fooi_(&i__1);
17391 // FFEINTRIN_imp_INT_D //
17392     i__1 = (integer) d1;
17393     fooi_(&i__1);
17394 // FFEINTRIN_imp_INT_I //
17395     i__1 = i1;
17396     fooi_(&i__1);
17397 // FFEINTRIN_imp_INT_R //
17398     i__1 = (integer) r1;
17399     fooi_(&i__1);
17400 // FFEINTRIN_imp_REAL_C //
17401     r__1 = c1.r;
17402     foor_(&r__1);
17403 // FFEINTRIN_imp_REAL_D //
17404     r__1 = (real) d1;
17405     foor_(&r__1);
17406 // FFEINTRIN_imp_REAL_I //
17407     r__1 = (real) i1;
17408     foor_(&r__1);
17409 // FFEINTRIN_imp_REAL_R //
17410     r__1 = r1;
17411     foor_(&r__1);
17412
17413 // FFEINTRIN_imp_INT_D: //
17414
17415 // FFEINTRIN_specIDINT //
17416     i__1 = (integer) d1;
17417     fooi_(&i__1);
17418
17419 // FFEINTRIN_imp_INT_R: //
17420
17421 // FFEINTRIN_specIFIX //
17422     i__1 = (integer) r1;
17423     fooi_(&i__1);
17424 // FFEINTRIN_specINT //
17425     i__1 = (integer) r1;
17426     fooi_(&i__1);
17427
17428 // FFEINTRIN_imp_REAL_D: //
17429
17430 // FFEINTRIN_specSNGL //
17431     r__1 = (real) d1;
17432     foor_(&r__1);
17433
17434 // FFEINTRIN_imp_REAL_I: //
17435
17436 // FFEINTRIN_specFLOAT //
17437     r__1 = (real) i1;
17438     foor_(&r__1);
17439 // FFEINTRIN_specREAL //
17440     r__1 = (real) i1;
17441     foor_(&r__1);
17442
17443 } // MAIN__ //
17444
17445 -------- (end output file from f2c)
17446
17447 */