gcc/f/com.c

   1 /* com.c -- Implementation File (module.c template V1.0)
   2    Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000
   3    Free Software Foundation, Inc.
   4    Contributed by James Craig Burley.
   5
   6 This file is part of GNU Fortran.
   7
   8 GNU Fortran is free software; you can redistribute it and/or modify
   9 it under the terms of the GNU General Public License as published by
  10 the Free Software Foundation; either version 2, or (at your option)
  11 any later version.
  12
  13 GNU Fortran is distributed in the hope that it will be useful,
  14 but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 GNU General Public License for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GNU Fortran; see the file COPYING.  If not, write to
  20 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
  21 02111-1307, USA.
  22
  23    Related Modules:
  24       None
  25
  26    Description:
  27       Contains compiler-specific functions.
  28
  29    Modifications:
  30 */
  31
  32 /* Understanding this module means understanding the interface between
  33    the g77 front end and the gcc back end (or, perhaps, some other
  34    back end).  In here are the functions called by the front end proper
  35    to notify whatever back end is in place about certain things, and
  36    also the back-end-specific functions.  It's a bear to deal with, so
  37    lately I've been trying to simplify things, especially with regard
  38    to the gcc-back-end-specific stuff.
  39
  40    Building expressions generally seems quite easy, but building decls
  41    has been challenging and is undergoing revision.  gcc has several
  42    kinds of decls:
  43
  44    TYPE_DECL -- a type (int, float, struct, function, etc.)
  45    CONST_DECL -- a constant of some type other than function
  46    LABEL_DECL -- a variable or a constant?
  47    PARM_DECL -- an argument to a function (a variable that is a dummy)
  48    RESULT_DECL -- the return value of a function (a variable)
  49    VAR_DECL -- other variable (can hold a ptr-to-function, struct, int, etc.)
  50    FUNCTION_DECL -- a function (either the actual function or an extern ref)
  51    FIELD_DECL -- a field in a struct or union (goes into types)
  52
  53    g77 has a set of functions that somewhat parallels the gcc front end
  54    when it comes to building decls:
  55
  56    Internal Function (one we define, not just declare as extern):
  57    int yes;
  58    yes = suspend_momentary ();
  59    if (is_nested) push_f_function_context ();
  60    start_function (get_identifier ("function_name"), function_type,
  61                    is_nested, is_public);
  62    // for each arg, build PARM_DECL and call push_parm_decl (decl) with it;
  63    store_parm_decls (is_main_program);
  64    ffecom_start_compstmt ();
  65    // for stmts and decls inside function, do appropriate things;
  66    ffecom_end_compstmt ();
  67    finish_function (is_nested);
  68    if (is_nested) pop_f_function_context ();
  69    if (is_nested) resume_momentary (yes);
  70
  71    Everything Else:
  72    int yes;
  73    tree d;
  74    tree init;
  75    yes = suspend_momentary ();
  76    // fill in external, public, static, &c for decl, and
  77    // set DECL_INITIAL to error_mark_node if going to initialize
  78    // set is_top_level TRUE only if not at top level and decl
  79    // must go in top level (i.e. not within current function decl context)
  80    d = start_decl (decl, is_top_level);
  81    init = ...;  // if have initializer
  82    finish_decl (d, init, is_top_level);
  83    resume_momentary (yes);
  84
  85 */
  86
  87 /* Include files. */
  88
  89 #include "proj.h"
  90 #if FFECOM_targetCURRENT == FFECOM_targetGCC
  91 #include "flags.h"
  92 #include "rtl.h"
  93 #include "toplev.h"
  94 #include "tree.h"
  95 #include "output.h"  /* Must follow tree.h so TREE_CODE is defined! */
  96 #include "convert.h"
  97 #include "ggc.h"
  98 #include "defaults.h"
  99 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 100
 101 #define FFECOM_GCC_INCLUDE 1    /* Enable -I. */
 102
 103 /* BEGIN stuff from gcc/cccp.c.  */
 104
 105 /* The following symbols should be autoconfigured:
 106         HAVE_FCNTL_H
 107         HAVE_STDLIB_H
 108         HAVE_SYS_TIME_H
 109         HAVE_UNISTD_H
 110         STDC_HEADERS
 111         TIME_WITH_SYS_TIME
 112    In the mean time, we'll get by with approximations based
 113    on existing GCC configuration symbols.  */
 114
 115 #ifdef POSIX
 116 # ifndef HAVE_STDLIB_H
 117 # define HAVE_STDLIB_H 1
 118 # endif
 119 # ifndef HAVE_UNISTD_H
 120 # define HAVE_UNISTD_H 1
 121 # endif
 122 # ifndef STDC_HEADERS
 123 # define STDC_HEADERS 1
 124 # endif
 125 #endif /* defined (POSIX) */
 126
 127 #if defined (POSIX) || (defined (USG) && !defined (VMS))
 128 # ifndef HAVE_FCNTL_H
 129 # define HAVE_FCNTL_H 1
 130 # endif
 131 #endif
 132
 133 #ifndef RLIMIT_STACK
 134 # include <time.h>
 135 #else
 136 # if TIME_WITH_SYS_TIME
 137 #  include <sys/time.h>
 138 #  include <time.h>
 139 # else
 140 #  if HAVE_SYS_TIME_H
 141 #   include <sys/time.h>
 142 #  else
 143 #   include <time.h>
 144 #  endif
 145 # endif
 146 # include <sys/resource.h>
 147 #endif
 148
 149 #if HAVE_FCNTL_H
 150 # include <fcntl.h>
 151 #endif
 152
 153 /* This defines "errno" properly for VMS, and gives us EACCES. */
 154 #include <errno.h>
 155
 156 #if HAVE_STDLIB_H
 157 # include <stdlib.h>
 158 #else
 159 char *getenv ();
 160 #endif
 161
 162 #if HAVE_UNISTD_H
 163 # include <unistd.h>
 164 #endif
 165
 166 /* VMS-specific definitions */
 167 #ifdef VMS
 168 #include <descrip.h>
 169 #define O_RDONLY        0       /* Open arg for Read/Only  */
 170 #define O_WRONLY        1       /* Open arg for Write/Only */
 171 #define read(fd,buf,size)       VMS_read (fd,buf,size)
 172 #define write(fd,buf,size)      VMS_write (fd,buf,size)
 173 #define open(fname,mode,prot)   VMS_open (fname,mode,prot)
 174 #define fopen(fname,mode)       VMS_fopen (fname,mode)
 175 #define freopen(fname,mode,ofile) VMS_freopen (fname,mode,ofile)
 176 #define strncat(dst,src,cnt) VMS_strncat (dst,src,cnt)
 177 #define fstat(fd,stbuf)         VMS_fstat (fd,stbuf)
 178 static int VMS_fstat (), VMS_stat ();
 179 static char * VMS_strncat ();
 180 static int VMS_read ();
 181 static int VMS_write ();
 182 static int VMS_open ();
 183 static FILE * VMS_fopen ();
 184 static FILE * VMS_freopen ();
 185 static void hack_vms_include_specification ();
 186 typedef struct { unsigned :16, :16, :16; } vms_ino_t;
 187 #define ino_t vms_ino_t
 188 #define INCLUDE_LEN_FUDGE 10    /* leave room for VMS syntax conversion */
 189 #ifdef __GNUC__
 190 #define BSTRING                 /* VMS/GCC supplies the bstring routines */
 191 #endif /* __GNUC__ */
 192 #endif /* VMS */
 193
 194 #ifndef O_RDONLY
 195 #define O_RDONLY 0
 196 #endif
 197
 198 /* END stuff from gcc/cccp.c.  */
 199
 200 #define FFECOM_DETERMINE_TYPES 1 /* for com.h */
 201 #include "com.h"
 202 #include "bad.h"
 203 #include "bld.h"
 204 #include "equiv.h"
 205 #include "expr.h"
 206 #include "implic.h"
 207 #include "info.h"
 208 #include "malloc.h"
 209 #include "src.h"
 210 #include "st.h"
 211 #include "storag.h"
 212 #include "symbol.h"
 213 #include "target.h"
 214 #include "top.h"
 215 #include "type.h"
 216
 217 /* Externals defined here.  */
 218
 219 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 220
 221 /* ~~gcc/tree.h *should* declare this, because toplev.c and dwarfout.c
 222    reference it.  */
 223
 224 const char * const language_string = "GNU F77";
 225
 226 /* Stream for reading from the input file.  */
 227 FILE *finput;
 228
 229 /* These definitions parallel those in c-decl.c so that code from that
 230    module can be used pretty much as is.  Much of these defs aren't
 231    otherwise used, i.e. by g77 code per se, except some of them are used
 232    to build some of them that are.  The ones that are global (i.e. not
 233    "static") are those that ste.c and such might use (directly
 234    or by using com macros that reference them in their definitions).  */
 235
 236 tree string_type_node;
 237
 238 /* The rest of these are inventions for g77, though there might be
 239    similar things in the C front end.  As they are found, these
 240    inventions should be renamed to be canonical.  Note that only
 241    the ones currently required to be global are so.  */
 242
 243 static tree ffecom_tree_fun_type_void;
 244
 245 tree ffecom_integer_type_node;  /* Abbrev for _tree_type[blah][blah]. */
 246 tree ffecom_integer_zero_node;  /* Like *_*_* with g77's integer type. */
 247 tree ffecom_integer_one_node;   /* " */
 248 tree ffecom_tree_type[FFEINFO_basictype][FFEINFO_kindtype];
 249
 250 /* _fun_type things are the f2c-specific versions.  For -fno-f2c,
 251    just use build_function_type and build_pointer_type on the
 252    appropriate _tree_type array element.  */
 253
 254 static tree ffecom_tree_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
 255 static tree ffecom_tree_ptr_to_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
 256 static tree ffecom_tree_subr_type;
 257 static tree ffecom_tree_ptr_to_subr_type;
 258 static tree ffecom_tree_blockdata_type;
 259
 260 static tree ffecom_tree_xargc_;
 261
 262 ffecomSymbol ffecom_symbol_null_
 263 =
 264 {
 265   NULL_TREE,
 266   NULL_TREE,
 267   NULL_TREE,
 268   NULL_TREE,
 269   false
 270 };
 271 ffeinfoKindtype ffecom_pointer_kind_ = FFEINFO_basictypeNONE;
 272 ffeinfoKindtype ffecom_label_kind_ = FFEINFO_basictypeNONE;
 273
 274 int ffecom_f2c_typecode_[FFEINFO_basictype][FFEINFO_kindtype];
 275 tree ffecom_f2c_integer_type_node;
 276 tree ffecom_f2c_ptr_to_integer_type_node;
 277 tree ffecom_f2c_address_type_node;
 278 tree ffecom_f2c_real_type_node;
 279 tree ffecom_f2c_ptr_to_real_type_node;
 280 tree ffecom_f2c_doublereal_type_node;
 281 tree ffecom_f2c_complex_type_node;
 282 tree ffecom_f2c_doublecomplex_type_node;
 283 tree ffecom_f2c_longint_type_node;
 284 tree ffecom_f2c_logical_type_node;
 285 tree ffecom_f2c_flag_type_node;
 286 tree ffecom_f2c_ftnlen_type_node;
 287 tree ffecom_f2c_ftnlen_zero_node;
 288 tree ffecom_f2c_ftnlen_one_node;
 289 tree ffecom_f2c_ftnlen_two_node;
 290 tree ffecom_f2c_ptr_to_ftnlen_type_node;
 291 tree ffecom_f2c_ftnint_type_node;
 292 tree ffecom_f2c_ptr_to_ftnint_type_node;
 293 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 294
 295 /* Simple definitions and enumerations. */
 296
 297 #ifndef FFECOM_sizeMAXSTACKITEM
 298 #define FFECOM_sizeMAXSTACKITEM 32*1024 /* Keep user-declared things
 299                                            larger than this # bytes
 300                                            off stack if possible. */
 301 #endif
 302
 303 /* For systems that have large enough stacks, they should define
 304    this to 0, and here, for ease of use later on, we just undefine
 305    it if it is 0.  */
 306
 307 #if FFECOM_sizeMAXSTACKITEM == 0
 308 #undef FFECOM_sizeMAXSTACKITEM
 309 #endif
 310
 311 typedef enum
 312   {
 313     FFECOM_rttypeVOID_,
 314     FFECOM_rttypeVOIDSTAR_,     /* C's `void *' type. */
 315     FFECOM_rttypeFTNINT_,       /* f2c's `ftnint' type. */
 316     FFECOM_rttypeINTEGER_,      /* f2c's `integer' type. */
 317     FFECOM_rttypeLONGINT_,      /* f2c's `longint' type. */
 318     FFECOM_rttypeLOGICAL_,      /* f2c's `logical' type. */
 319     FFECOM_rttypeREAL_F2C_,     /* f2c's `real' returned as `double'. */
 320     FFECOM_rttypeREAL_GNU_,     /* `real' returned as such. */
 321     FFECOM_rttypeCOMPLEX_F2C_,  /* f2c's `complex' returned via 1st arg. */
 322     FFECOM_rttypeCOMPLEX_GNU_,  /* f2c's `complex' returned directly. */
 323     FFECOM_rttypeDOUBLE_,       /* C's `double' type. */
 324     FFECOM_rttypeDOUBLEREAL_,   /* f2c's `doublereal' type. */
 325     FFECOM_rttypeDBLCMPLX_F2C_, /* f2c's `doublecomplex' returned via 1st arg. */
 326     FFECOM_rttypeDBLCMPLX_GNU_, /* f2c's `doublecomplex' returned directly. */
 327     FFECOM_rttypeCHARACTER_,    /* f2c `char *'/`ftnlen' pair. */
 328     FFECOM_rttype_
 329   } ffecomRttype_;
 330
 331 /* Internal typedefs. */
 332
 333 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 334 typedef struct _ffecom_concat_list_ ffecomConcatList_;
 335 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 336
 337 /* Private include files. */
 338
 339
 340 /* Internal structure definitions. */
 341
 342 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 343 struct _ffecom_concat_list_
 344   {
 345     ffebld *exprs;
 346     int count;
 347     int max;
 348     ffetargetCharacterSize minlen;
 349     ffetargetCharacterSize maxlen;
 350   };
 351 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 352
 353 /* Static functions (internal). */
 354
 355 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 356 static tree ffecom_arglist_expr_ (const char *argstring, ffebld args);
 357 static tree ffecom_widest_expr_type_ (ffebld list);
 358 static bool ffecom_overlap_ (tree dest_decl, tree dest_offset,
 359                              tree dest_size, tree source_tree,
 360                              ffebld source, bool scalar_arg);
 361 static bool ffecom_args_overlapping_ (tree dest_tree, ffebld dest,
 362                                       tree args, tree callee_commons,
 363                                       bool scalar_args);
 364 static tree ffecom_build_f2c_string_ (int i, const char *s);
 365 static tree ffecom_call_ (tree fn, ffeinfoKindtype kt,
 366                           bool is_f2c_complex, tree type,
 367                           tree args, tree dest_tree,
 368                           ffebld dest, bool *dest_used,
 369                           tree callee_commons, bool scalar_args, tree hook);
 370 static tree ffecom_call_binop_ (tree fn, ffeinfoKindtype kt,
 371                                 bool is_f2c_complex, tree type,
 372                                 ffebld left, ffebld right,
 373                                 tree dest_tree, ffebld dest,
 374                                 bool *dest_used, tree callee_commons,
 375                                 bool scalar_args, bool ref, tree hook);
 376 static void ffecom_char_args_x_ (tree *xitem, tree *length,
 377                                  ffebld expr, bool with_null);
 378 static tree ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy);
 379 static tree ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s);
 380 static ffecomConcatList_
 381   ffecom_concat_list_gather_ (ffecomConcatList_ catlist,
 382                               ffebld expr,
 383                               ffetargetCharacterSize max);
 384 static void ffecom_concat_list_kill_ (ffecomConcatList_ catlist);
 385 static ffecomConcatList_ ffecom_concat_list_new_ (ffebld expr,
 386                                                 ffetargetCharacterSize max);
 387 static void ffecom_debug_kludge_ (tree aggr, const char *aggr_type,
 388                                   ffesymbol member, tree member_type,
 389                                   ffetargetOffset offset);
 390 static void ffecom_do_entry_ (ffesymbol fn, int entrynum);
 391 static tree ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
 392                           bool *dest_used, bool assignp, bool widenp);
 393 static tree ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
 394                                     ffebld dest, bool *dest_used);
 395 static tree ffecom_expr_power_integer_ (ffebld expr);
 396 static void ffecom_expr_transform_ (ffebld expr);
 397 static void ffecom_f2c_make_type_ (tree *type, int tcode, const char *name);
 398 static void ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
 399                                       int code);
 400 static ffeglobal ffecom_finish_global_ (ffeglobal global);
 401 static ffesymbol ffecom_finish_symbol_transform_ (ffesymbol s);
 402 static tree ffecom_get_appended_identifier_ (char us, const char *text);
 403 static tree ffecom_get_external_identifier_ (ffesymbol s);
 404 static tree ffecom_get_identifier_ (const char *text);
 405 static tree ffecom_gen_sfuncdef_ (ffesymbol s,
 406                                   ffeinfoBasictype bt,
 407                                   ffeinfoKindtype kt);
 408 static const char *ffecom_gfrt_args_ (ffecomGfrt ix);
 409 static tree ffecom_gfrt_tree_ (ffecomGfrt ix);
 410 static tree ffecom_init_zero_ (tree decl);
 411 static tree ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
 412                                      tree *maybe_tree);
 413 static tree ffecom_intrinsic_len_ (ffebld expr);
 414 static void ffecom_let_char_ (tree dest_tree,
 415                               tree dest_length,
 416                               ffetargetCharacterSize dest_size,
 417                               ffebld source);
 418 static void ffecom_make_gfrt_ (ffecomGfrt ix);
 419 static void ffecom_member_phase1_ (ffestorag mst, ffestorag st);
 420 static void ffecom_member_phase2_ (ffestorag mst, ffestorag st);
 421 static void ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size,
 422                                       ffebld source);
 423 static void ffecom_push_dummy_decls_ (ffebld dumlist,
 424                                       bool stmtfunc);
 425 static void ffecom_start_progunit_ (void);
 426 static ffesymbol ffecom_sym_transform_ (ffesymbol s);
 427 static ffesymbol ffecom_sym_transform_assign_ (ffesymbol s);
 428 static void ffecom_transform_common_ (ffesymbol s);
 429 static void ffecom_transform_equiv_ (ffestorag st);
 430 static tree ffecom_transform_namelist_ (ffesymbol s);
 431 static void ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
 432                                        tree t);
 433 static void ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
 434                                        tree *size, tree tree);
 435 static tree ffecom_tree_divide_ (tree tree_type, tree left, tree right,
 436                                  tree dest_tree, ffebld dest,
 437                                  bool *dest_used, tree hook);
 438 static tree ffecom_type_localvar_ (ffesymbol s,
 439                                    ffeinfoBasictype bt,
 440                                    ffeinfoKindtype kt);
 441 static tree ffecom_type_namelist_ (void);
 442 static tree ffecom_type_vardesc_ (void);
 443 static tree ffecom_vardesc_ (ffebld expr);
 444 static tree ffecom_vardesc_array_ (ffesymbol s);
 445 static tree ffecom_vardesc_dims_ (ffesymbol s);
 446 static tree ffecom_convert_narrow_ (tree type, tree expr);
 447 static tree ffecom_convert_widen_ (tree type, tree expr);
 448 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 449
 450 /* These are static functions that parallel those found in the C front
 451    end and thus have the same names.  */
 452
 453 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 454 static tree bison_rule_compstmt_ (void);
 455 static void bison_rule_pushlevel_ (void);
 456 static void delete_block (tree block);
 457 static int duplicate_decls (tree newdecl, tree olddecl);
 458 static void finish_decl (tree decl, tree init, bool is_top_level);
 459 static void finish_function (int nested);
 460 static const char *lang_printable_name (tree decl, int v);
 461 static tree lookup_name_current_level (tree name);
 462 static struct binding_level *make_binding_level (void);
 463 static void pop_f_function_context (void);
 464 static void push_f_function_context (void);
 465 static void push_parm_decl (tree parm);
 466 static tree pushdecl_top_level (tree decl);
 467 static int kept_level_p (void);
 468 static tree storedecls (tree decls);
 469 static void store_parm_decls (int is_main_program);
 470 static tree start_decl (tree decl, bool is_top_level);
 471 static void start_function (tree name, tree type, int nested, int public);
 472 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 473 #if FFECOM_GCC_INCLUDE
 474 static void ffecom_file_ (const char *name);
 475 static void ffecom_initialize_char_syntax_ (void);
 476 static void ffecom_close_include_ (FILE *f);
 477 static int ffecom_decode_include_option_ (char *spec);
 478 static FILE *ffecom_open_include_ (char *name, ffewhereLine l,
 479                                    ffewhereColumn c);
 480 #endif  /* FFECOM_GCC_INCLUDE */
 481
 482 /* Static objects accessed by functions in this module. */
 483
 484 static ffesymbol ffecom_primary_entry_ = NULL;
 485 static ffesymbol ffecom_nested_entry_ = NULL;
 486 static ffeinfoKind ffecom_primary_entry_kind_;
 487 static bool ffecom_primary_entry_is_proc_;
 488 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 489 static tree ffecom_outer_function_decl_;
 490 static tree ffecom_previous_function_decl_;
 491 static tree ffecom_which_entrypoint_decl_;
 492 static tree ffecom_float_zero_ = NULL_TREE;
 493 static tree ffecom_float_half_ = NULL_TREE;
 494 static tree ffecom_double_zero_ = NULL_TREE;
 495 static tree ffecom_double_half_ = NULL_TREE;
 496 static tree ffecom_func_result_;/* For functions. */
 497 static tree ffecom_func_length_;/* For CHARACTER fns. */
 498 static ffebld ffecom_list_blockdata_;
 499 static ffebld ffecom_list_common_;
 500 static ffebld ffecom_master_arglist_;
 501 static ffeinfoBasictype ffecom_master_bt_;
 502 static ffeinfoKindtype ffecom_master_kt_;
 503 static ffetargetCharacterSize ffecom_master_size_;
 504 static int ffecom_num_fns_ = 0;
 505 static int ffecom_num_entrypoints_ = 0;
 506 static bool ffecom_is_altreturning_ = FALSE;
 507 static tree ffecom_multi_type_node_;
 508 static tree ffecom_multi_retval_;
 509 static tree
 510   ffecom_multi_fields_[FFEINFO_basictype][FFEINFO_kindtype];
 511 static bool ffecom_member_namelisted_;  /* _member_phase1_ namelisted? */
 512 static bool ffecom_doing_entry_ = FALSE;
 513 static bool ffecom_transform_only_dummies_ = FALSE;
 514 static int ffecom_typesize_pointer_;
 515 static int ffecom_typesize_integer1_;
 516
 517 /* Holds pointer-to-function expressions.  */
 518
 519 static tree ffecom_gfrt_[FFECOM_gfrt]
 520 =
 521 {
 522 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NULL_TREE,
 523 #include "com-rt.def"
 524 #undef DEFGFRT
 525 };
 526
 527 /* Holds the external names of the functions.  */
 528
 529 static const char *ffecom_gfrt_name_[FFECOM_gfrt]
 530 =
 531 {
 532 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NAME,
 533 #include "com-rt.def"
 534 #undef DEFGFRT
 535 };
 536
 537 /* Whether the function returns.  */
 538
 539 static bool ffecom_gfrt_volatile_[FFECOM_gfrt]
 540 =
 541 {
 542 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) VOLATILE,
 543 #include "com-rt.def"
 544 #undef DEFGFRT
 545 };
 546
 547 /* Whether the function returns type complex.  */
 548
 549 static bool ffecom_gfrt_complex_[FFECOM_gfrt]
 550 =
 551 {
 552 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) COMPLEX,
 553 #include "com-rt.def"
 554 #undef DEFGFRT
 555 };
 556
 557 /* Whether the function is const
 558    (i.e., has no side effects and only depends on its arguments).  */
 559
 560 static bool ffecom_gfrt_const_[FFECOM_gfrt]
 561 =
 562 {
 563 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) CONST,
 564 #include "com-rt.def"
 565 #undef DEFGFRT
 566 };
 567
 568 /* Type code for the function return value.  */
 569
 570 static ffecomRttype_ ffecom_gfrt_type_[FFECOM_gfrt]
 571 =
 572 {
 573 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) TYPE,
 574 #include "com-rt.def"
 575 #undef DEFGFRT
 576 };
 577
 578 /* String of codes for the function's arguments.  */
 579
 580 static const char *ffecom_gfrt_argstring_[FFECOM_gfrt]
 581 =
 582 {
 583 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) ARGS,
 584 #include "com-rt.def"
 585 #undef DEFGFRT
 586 };
 587 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 588
 589 /* Internal macros. */
 590
 591 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 592
 593 /* We let tm.h override the types used here, to handle trivial differences
 594    such as the choice of unsigned int or long unsigned int for size_t.
 595    When machines start needing nontrivial differences in the size type,
 596    it would be best to do something here to figure out automatically
 597    from other information what type to use.  */
 598
 599 #ifndef SIZE_TYPE
 600 #define SIZE_TYPE "long unsigned int"
 601 #endif
 602
 603 #define ffecom_concat_list_count_(catlist) ((catlist).count)
 604 #define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)])
 605 #define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen)
 606 #define ffecom_concat_list_minlen_(catlist) ((catlist).minlen)
 607
 608 #define ffecom_char_args_(i,l,e) ffecom_char_args_x_((i),(l),(e),FALSE)
 609 #define ffecom_char_args_with_null_(i,l,e) ffecom_char_args_x_((i),(l),(e),TRUE)
 610
 611 /* For each binding contour we allocate a binding_level structure
 612  * which records the names defined in that contour.
 613  * Contours include:
 614  *  0) the global one
 615  *  1) one for each function definition,
 616  *     where internal declarations of the parameters appear.
 617  *
 618  * The current meaning of a name can be found by searching the levels from
 619  * the current one out to the global one.
 620  */
 621
 622 /* Note that the information in the `names' component of the global contour
 623    is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers.  */
 624
 625 struct binding_level
 626   {
 627     /* A chain of _DECL nodes for all variables, constants, functions,
 628        and typedef types.  These are in the reverse of the order supplied.
 629      */
 630     tree names;
 631
 632     /* For each level (except not the global one),
 633        a chain of BLOCK nodes for all the levels
 634        that were entered and exited one level down.  */
 635     tree blocks;
 636
 637     /* The BLOCK node for this level, if one has been preallocated.
 638        If 0, the BLOCK is allocated (if needed) when the level is popped.  */
 639     tree this_block;
 640
 641     /* The binding level which this one is contained in (inherits from).  */
 642     struct binding_level *level_chain;
 643
 644     /* 0: no ffecom_prepare_* functions called at this level yet;
 645        1: ffecom_prepare* functions called, except not ffecom_prepare_end;
 646        2: ffecom_prepare_end called.  */
 647     int prep_state;
 648   };
 649
 650 #define NULL_BINDING_LEVEL (struct binding_level *) NULL
 651
 652 /* The binding level currently in effect.  */
 653
 654 static struct binding_level *current_binding_level;
 655
 656 /* A chain of binding_level structures awaiting reuse.  */
 657
 658 static struct binding_level *free_binding_level;
 659
 660 /* The outermost binding level, for names of file scope.
 661    This is created when the compiler is started and exists
 662    through the entire run.  */
 663
 664 static struct binding_level *global_binding_level;
 665
 666 /* Binding level structures are initialized by copying this one.  */
 667
 668 static struct binding_level clear_binding_level
 669 =
 670 {NULL, NULL, NULL, NULL_BINDING_LEVEL, 0};
 671
 672 /* Language-dependent contents of an identifier.  */
 673
 674 struct lang_identifier
 675   {
 676     struct tree_identifier ignore;
 677     tree global_value, local_value, label_value;
 678     bool invented;
 679   };
 680
 681 /* Macros for access to language-specific slots in an identifier.  */
 682 /* Each of these slots contains a DECL node or null.  */
 683
 684 /* This represents the value which the identifier has in the
 685    file-scope namespace.  */
 686 #define IDENTIFIER_GLOBAL_VALUE(NODE)   \
 687   (((struct lang_identifier *)(NODE))->global_value)
 688 /* This represents the value which the identifier has in the current
 689    scope.  */
 690 #define IDENTIFIER_LOCAL_VALUE(NODE)    \
 691   (((struct lang_identifier *)(NODE))->local_value)
 692 /* This represents the value which the identifier has as a label in
 693    the current label scope.  */
 694 #define IDENTIFIER_LABEL_VALUE(NODE)    \
 695   (((struct lang_identifier *)(NODE))->label_value)
 696 /* This is nonzero if the identifier was "made up" by g77 code.  */
 697 #define IDENTIFIER_INVENTED(NODE)       \
 698   (((struct lang_identifier *)(NODE))->invented)
 699
 700 /* In identifiers, C uses the following fields in a special way:
 701    TREE_PUBLIC        to record that there was a previous local extern decl.
 702    TREE_USED          to record that such a decl was used.
 703    TREE_ADDRESSABLE   to record that the address of such a decl was used.  */
 704
 705 /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
 706    that have names.  Here so we can clear out their names' definitions
 707    at the end of the function.  */
 708
 709 static tree named_labels;
 710
 711 /* A list of LABEL_DECLs from outer contexts that are currently shadowed.  */
 712
 713 static tree shadowed_labels;
 714
 715 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 716 \f
 717 /* Return the subscript expression, modified to do range-checking.
 718
 719    `array' is the array to be checked against.
 720    `element' is the subscript expression to check.
 721    `dim' is the dimension number (starting at 0).
 722    `total_dims' is the total number of dimensions (0 for CHARACTER substring).
 723 */
 724
 725 static tree
 726 ffecom_subscript_check_ (tree array, tree element, int dim, int total_dims,
 727                          const char *array_name)
 728 {
 729   tree low = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 730   tree high = TYPE_MAX_VALUE (TYPE_DOMAIN (array));
 731   tree cond;
 732   tree die;
 733   tree args;
 734
 735   if (element == error_mark_node)
 736     return element;
 737
 738   if (TREE_TYPE (low) != TREE_TYPE (element))
 739     {
 740       if (TYPE_PRECISION (TREE_TYPE (low))
 741           > TYPE_PRECISION (TREE_TYPE (element)))
 742         element = convert (TREE_TYPE (low), element);
 743       else
 744         {
 745           low = convert (TREE_TYPE (element), low);
 746           if (high)
 747             high = convert (TREE_TYPE (element), high);
 748         }
 749     }
 750
 751   element = ffecom_save_tree (element);
 752   cond = ffecom_2 (LE_EXPR, integer_type_node,
 753                    low,
 754                    element);
 755   if (high)
 756     {
 757       cond = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
 758                        cond,
 759                        ffecom_2 (LE_EXPR, integer_type_node,
 760                                  element,
 761                                  high));
 762     }
 763
 764   {
 765     int len;
 766     char *proc;
 767     char *var;
 768     tree arg3;
 769     tree arg2;
 770     tree arg1;
 771     tree arg4;
 772
 773     switch (total_dims)
 774       {
 775       case 0:
 776         var = xmalloc (strlen (array_name) + 20);
 777         sprintf (var, "%s[%s-substring]",
 778                  array_name,
 779                  dim ? "end" : "start");
 780         len = strlen (var) + 1;
 781         arg1 = build_string (len, var);
 782         free (var);
 783         break;
 784
 785       case 1:
 786         len = strlen (array_name) + 1;
 787         arg1 = build_string (len, array_name);
 788         break;
 789
 790       default:
 791         var = xmalloc (strlen (array_name) + 40);
 792         sprintf (var, "%s[subscript-%d-of-%d]",
 793                  array_name,
 794                  dim + 1, total_dims);
 795         len = strlen (var) + 1;
 796         arg1 = build_string (len, var);
 797         free (var);
 798         break;
 799       }
 800
 801     TREE_TYPE (arg1)
 802       = build_type_variant (build_array_type (char_type_node,
 803                                               build_range_type
 804                                               (integer_type_node,
 805                                                integer_one_node,
 806                                                build_int_2 (len, 0))),
 807                             1, 0);
 808     TREE_CONSTANT (arg1) = 1;
 809     TREE_STATIC (arg1) = 1;
 810     arg1 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg1)),
 811                      arg1);
 812
 813     /* s_rnge adds one to the element to print it, so bias against
 814        that -- want to print a faithful *subscript* value.  */
 815     arg2 = convert (ffecom_f2c_ftnint_type_node,
 816                     ffecom_2 (MINUS_EXPR,
 817                               TREE_TYPE (element),
 818                               element,
 819                               convert (TREE_TYPE (element),
 820                                        integer_one_node)));
 821
 822     proc = xmalloc ((len = strlen (input_filename)
 823                      + IDENTIFIER_LENGTH (DECL_NAME (current_function_decl))
 824                      + 2));
 825
 826     sprintf (&proc[0], "%s/%s",
 827              input_filename,
 828              IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
 829     arg3 = build_string (len, proc);
 830
 831     free (proc);
 832
 833     TREE_TYPE (arg3)
 834       = build_type_variant (build_array_type (char_type_node,
 835                                               build_range_type
 836                                               (integer_type_node,
 837                                                integer_one_node,
 838                                                build_int_2 (len, 0))),
 839                             1, 0);
 840     TREE_CONSTANT (arg3) = 1;
 841     TREE_STATIC (arg3) = 1;
 842     arg3 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg3)),
 843                      arg3);
 844
 845     arg4 = convert (ffecom_f2c_ftnint_type_node,
 846                     build_int_2 (lineno, 0));
 847
 848     arg1 = build_tree_list (NULL_TREE, arg1);
 849     arg2 = build_tree_list (NULL_TREE, arg2);
 850     arg3 = build_tree_list (NULL_TREE, arg3);
 851     arg4 = build_tree_list (NULL_TREE, arg4);
 852     TREE_CHAIN (arg3) = arg4;
 853     TREE_CHAIN (arg2) = arg3;
 854     TREE_CHAIN (arg1) = arg2;
 855
 856     args = arg1;
 857   }
 858   die = ffecom_call_gfrt (FFECOM_gfrtRANGE,
 859                           args, NULL_TREE);
 860   TREE_SIDE_EFFECTS (die) = 1;
 861
 862   element = ffecom_3 (COND_EXPR,
 863                       TREE_TYPE (element),
 864                       cond,
 865                       element,
 866                       die);
 867
 868   return element;
 869 }
 870
 871 /* Return the computed element of an array reference.
 872
 873    `item' is NULL_TREE, or the transformed pointer to the array.
 874    `expr' is the original opARRAYREF expression, which is transformed
 875      if `item' is NULL_TREE.
 876    `want_ptr' is non-zero if a pointer to the element, instead of
 877      the element itself, is to be returned.  */
 878
 879 static tree
 880 ffecom_arrayref_ (tree item, ffebld expr, int want_ptr)
 881 {
 882   ffebld dims[FFECOM_dimensionsMAX];
 883   int i;
 884   int total_dims;
 885   int flatten = ffe_is_flatten_arrays ();
 886   int need_ptr;
 887   tree array;
 888   tree element;
 889   tree tree_type;
 890   tree tree_type_x;
 891   const char *array_name;
 892   ffetype type;
 893   ffebld list;
 894
 895   if (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER)
 896     array_name = ffesymbol_text (ffebld_symter (ffebld_left (expr)));
 897   else
 898     array_name = "[expr?]";
 899
 900   /* Build up ARRAY_REFs in reverse order (since we're column major
 901      here in Fortran land). */
 902
 903   for (i = 0, list = ffebld_right (expr);
 904        list != NULL;
 905        ++i, list = ffebld_trail (list))
 906     {
 907       dims[i] = ffebld_head (list);
 908       type = ffeinfo_type (ffebld_basictype (dims[i]),
 909                            ffebld_kindtype (dims[i]));
 910       if (! flatten
 911           && ffecom_typesize_pointer_ > ffecom_typesize_integer1_
 912           && ffetype_size (type) > ffecom_typesize_integer1_)
 913         /* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit
 914            pointers and 32-bit integers.  Do the full 64-bit pointer
 915            arithmetic, for codes using arrays for nonstandard heap-like
 916            work.  */
 917         flatten = 1;
 918     }
 919
 920   total_dims = i;
 921
 922   need_ptr = want_ptr || flatten;
 923
 924   if (! item)
 925     {
 926       if (need_ptr)
 927         item = ffecom_ptr_to_expr (ffebld_left (expr));
 928       else
 929         item = ffecom_expr (ffebld_left (expr));
 930
 931       if (item == error_mark_node)
 932         return item;
 933
 934       if (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING
 935           && ! mark_addressable (item))
 936         return error_mark_node;
 937     }
 938
 939   if (item == error_mark_node)
 940     return item;
 941
 942   if (need_ptr)
 943     {
 944       tree min;
 945
 946       for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
 947            i >= 0;
 948            --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
 949         {
 950           min = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 951           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 952           if (flag_bounds_check)
 953             element = ffecom_subscript_check_ (array, element, i, total_dims,
 954                                                array_name);
 955           if (element == error_mark_node)
 956             return element;
 957
 958           /* Widen integral arithmetic as desired while preserving
 959              signedness.  */
 960           tree_type = TREE_TYPE (element);
 961           tree_type_x = tree_type;
 962           if (tree_type
 963               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
 964               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
 965             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
 966
 967           if (TREE_TYPE (min) != tree_type_x)
 968             min = convert (tree_type_x, min);
 969           if (TREE_TYPE (element) != tree_type_x)
 970             element = convert (tree_type_x, element);
 971
 972           item = ffecom_2 (PLUS_EXPR,
 973                            build_pointer_type (TREE_TYPE (array)),
 974                            item,
 975                            size_binop (MULT_EXPR,
 976                                        size_in_bytes (TREE_TYPE (array)),
 977                                        convert (sizetype,
 978                                                 fold (build (MINUS_EXPR,
 979                                                              tree_type_x,
 980                                                              element, min)))));
 981         }
 982       if (! want_ptr)
 983         {
 984           item = ffecom_1 (INDIRECT_REF,
 985                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
 986                            item);
 987         }
 988     }
 989   else
 990     {
 991       for (--i;
 992            i >= 0;
 993            --i)
 994         {
 995           array = TYPE_MAIN_VARIANT (TREE_TYPE (item));
 996
 997           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 998           if (flag_bounds_check)
 999             element = ffecom_subscript_check_ (array, element, i, total_dims,
1000                                                array_name);
1001           if (element == error_mark_node)
1002             return element;
1003
1004           /* Widen integral arithmetic as desired while preserving
1005              signedness.  */
1006           tree_type = TREE_TYPE (element);
1007           tree_type_x = tree_type;
1008           if (tree_type
1009               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
1010               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
1011             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
1012
1013           element = convert (tree_type_x, element);
1014
1015           item = ffecom_2 (ARRAY_REF,
1016                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
1017                            item,
1018                            element);
1019         }
1020     }
1021
1022   return item;
1023 }
1024
1025 /* This is like gcc's stabilize_reference -- in fact, most of the code
1026    comes from that -- but it handles the situation where the reference
1027    is going to have its subparts picked at, and it shouldn't change
1028    (or trigger extra invocations of functions in the subtrees) due to
1029    this.  save_expr is a bit overzealous, because we don't need the
1030    entire thing calculated and saved like a temp.  So, for DECLs, no
1031    change is needed, because these are stable aggregates, and ARRAY_REF
1032    and such might well be stable too, but for things like calculations,
1033    we do need to calculate a snapshot of a value before picking at it.  */
1034
1035 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1036 static tree
1037 ffecom_stabilize_aggregate_ (tree ref)
1038 {
1039   tree result;
1040   enum tree_code code = TREE_CODE (ref);
1041
1042   switch (code)
1043     {
1044     case VAR_DECL:
1045     case PARM_DECL:
1046     case RESULT_DECL:
1047       /* No action is needed in this case.  */
1048       return ref;
1049
1050     case NOP_EXPR:
1051     case CONVERT_EXPR:
1052     case FLOAT_EXPR:
1053     case FIX_TRUNC_EXPR:
1054     case FIX_FLOOR_EXPR:
1055     case FIX_ROUND_EXPR:
1056     case FIX_CEIL_EXPR:
1057       result = build_nt (code, stabilize_reference (TREE_OPERAND (ref, 0)));
1058       break;
1059
1060     case INDIRECT_REF:
1061       result = build_nt (INDIRECT_REF,
1062                          stabilize_reference_1 (TREE_OPERAND (ref, 0)));
1063       break;
1064
1065     case COMPONENT_REF:
1066       result = build_nt (COMPONENT_REF,
1067                          stabilize_reference (TREE_OPERAND (ref, 0)),
1068                          TREE_OPERAND (ref, 1));
1069       break;
1070
1071     case BIT_FIELD_REF:
1072       result = build_nt (BIT_FIELD_REF,
1073                          stabilize_reference (TREE_OPERAND (ref, 0)),
1074                          stabilize_reference_1 (TREE_OPERAND (ref, 1)),
1075                          stabilize_reference_1 (TREE_OPERAND (ref, 2)));
1076       break;
1077
1078     case ARRAY_REF:
1079       result = build_nt (ARRAY_REF,
1080                          stabilize_reference (TREE_OPERAND (ref, 0)),
1081                          stabilize_reference_1 (TREE_OPERAND (ref, 1)));
1082       break;
1083
1084     case COMPOUND_EXPR:
1085       result = build_nt (COMPOUND_EXPR,
1086                          stabilize_reference_1 (TREE_OPERAND (ref, 0)),
1087                          stabilize_reference (TREE_OPERAND (ref, 1)));
1088       break;
1089
1090     case RTL_EXPR:
1091       result = build1 (INDIRECT_REF, TREE_TYPE (ref),
1092                        save_expr (build1 (ADDR_EXPR,
1093                                           build_pointer_type (TREE_TYPE (ref)),
1094                                           ref)));
1095       break;
1096
1097
1098     default:
1099       return save_expr (ref);
1100
1101     case ERROR_MARK:
1102       return error_mark_node;
1103     }
1104
1105   TREE_TYPE (result) = TREE_TYPE (ref);
1106   TREE_READONLY (result) = TREE_READONLY (ref);
1107   TREE_SIDE_EFFECTS (result) = TREE_SIDE_EFFECTS (ref);
1108   TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
1109
1110   return result;
1111 }
1112 #endif
1113
1114 /* A rip-off of gcc's convert.c convert_to_complex function,
1115    reworked to handle complex implemented as C structures
1116    (RECORD_TYPE with two fields, real and imaginary `r' and `i').  */
1117
1118 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1119 static tree
1120 ffecom_convert_to_complex_ (tree type, tree expr)
1121 {
1122   register enum tree_code form = TREE_CODE (TREE_TYPE (expr));
1123   tree subtype;
1124
1125   assert (TREE_CODE (type) == RECORD_TYPE);
1126
1127   subtype = TREE_TYPE (TYPE_FIELDS (type));
1128
1129   if (form == REAL_TYPE || form == INTEGER_TYPE || form == ENUMERAL_TYPE)
1130     {
1131       expr = convert (subtype, expr);
1132       return ffecom_2 (COMPLEX_EXPR, type, expr,
1133                        convert (subtype, integer_zero_node));
1134     }
1135
1136   if (form == RECORD_TYPE)
1137     {
1138       tree elt_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr)));
1139       if (TYPE_MAIN_VARIANT (elt_type) == TYPE_MAIN_VARIANT (subtype))
1140         return expr;
1141       else
1142         {
1143           expr = save_expr (expr);
1144           return ffecom_2 (COMPLEX_EXPR,
1145                            type,
1146                            convert (subtype,
1147                                     ffecom_1 (REALPART_EXPR,
1148                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1149                                               expr)),
1150                            convert (subtype,
1151                                     ffecom_1 (IMAGPART_EXPR,
1152                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1153                                               expr)));
1154         }
1155     }
1156
1157   if (form == POINTER_TYPE || form == REFERENCE_TYPE)
1158     error ("pointer value used where a complex was expected");
1159   else
1160     error ("aggregate value used where a complex was expected");
1161
1162   return ffecom_2 (COMPLEX_EXPR, type,
1163                    convert (subtype, integer_zero_node),
1164                    convert (subtype, integer_zero_node));
1165 }
1166 #endif
1167
1168 /* Like gcc's convert(), but crashes if widening might happen.  */
1169
1170 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1171 static tree
1172 ffecom_convert_narrow_ (type, expr)
1173      tree type, expr;
1174 {
1175   register tree e = expr;
1176   register enum tree_code code = TREE_CODE (type);
1177
1178   if (type == TREE_TYPE (e)
1179       || TREE_CODE (e) == ERROR_MARK)
1180     return e;
1181   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1182     return fold (build1 (NOP_EXPR, type, e));
1183   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1184       || code == ERROR_MARK)
1185     return error_mark_node;
1186   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1187     {
1188       assert ("void value not ignored as it ought to be" == NULL);
1189       return error_mark_node;
1190     }
1191   assert (code != VOID_TYPE);
1192   if ((code != RECORD_TYPE)
1193       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1194     assert ("converting COMPLEX to REAL" == NULL);
1195   assert (code != ENUMERAL_TYPE);
1196   if (code == INTEGER_TYPE)
1197     {
1198       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1199                && TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)))
1200               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1201                   && (TYPE_PRECISION (type)
1202                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1203       return fold (convert_to_integer (type, e));
1204     }
1205   if (code == POINTER_TYPE)
1206     {
1207       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1208       return fold (convert_to_pointer (type, e));
1209     }
1210   if (code == REAL_TYPE)
1211     {
1212       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1213       assert (TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)));
1214       return fold (convert_to_real (type, e));
1215     }
1216   if (code == COMPLEX_TYPE)
1217     {
1218       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1219       assert (TYPE_PRECISION (TREE_TYPE (type)) <= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1220       return fold (convert_to_complex (type, e));
1221     }
1222   if (code == RECORD_TYPE)
1223     {
1224       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1225       /* Check that at least the first field name agrees.  */
1226       assert (DECL_NAME (TYPE_FIELDS (type))
1227               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1228       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1229               <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1230       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1231           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1232         return e;
1233       return fold (ffecom_convert_to_complex_ (type, e));
1234     }
1235
1236   assert ("conversion to non-scalar type requested" == NULL);
1237   return error_mark_node;
1238 }
1239 #endif
1240
1241 /* Like gcc's convert(), but crashes if narrowing might happen.  */
1242
1243 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1244 static tree
1245 ffecom_convert_widen_ (type, expr)
1246      tree type, expr;
1247 {
1248   register tree e = expr;
1249   register enum tree_code code = TREE_CODE (type);
1250
1251   if (type == TREE_TYPE (e)
1252       || TREE_CODE (e) == ERROR_MARK)
1253     return e;
1254   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1255     return fold (build1 (NOP_EXPR, type, e));
1256   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1257       || code == ERROR_MARK)
1258     return error_mark_node;
1259   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1260     {
1261       assert ("void value not ignored as it ought to be" == NULL);
1262       return error_mark_node;
1263     }
1264   assert (code != VOID_TYPE);
1265   if ((code != RECORD_TYPE)
1266       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1267     assert ("narrowing COMPLEX to REAL" == NULL);
1268   assert (code != ENUMERAL_TYPE);
1269   if (code == INTEGER_TYPE)
1270     {
1271       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1272                && TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)))
1273               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1274                   && (TYPE_PRECISION (type)
1275                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1276       return fold (convert_to_integer (type, e));
1277     }
1278   if (code == POINTER_TYPE)
1279     {
1280       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1281       return fold (convert_to_pointer (type, e));
1282     }
1283   if (code == REAL_TYPE)
1284     {
1285       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1286       assert (TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)));
1287       return fold (convert_to_real (type, e));
1288     }
1289   if (code == COMPLEX_TYPE)
1290     {
1291       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1292       assert (TYPE_PRECISION (TREE_TYPE (type)) >= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1293       return fold (convert_to_complex (type, e));
1294     }
1295   if (code == RECORD_TYPE)
1296     {
1297       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1298       /* Check that at least the first field name agrees.  */
1299       assert (DECL_NAME (TYPE_FIELDS (type))
1300               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1301       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1302               >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1303       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1304           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1305         return e;
1306       return fold (ffecom_convert_to_complex_ (type, e));
1307     }
1308
1309   assert ("conversion to non-scalar type requested" == NULL);
1310   return error_mark_node;
1311 }
1312 #endif
1313
1314 /* Handles making a COMPLEX type, either the standard
1315    (but buggy?) gbe way, or the safer (but less elegant?)
1316    f2c way.  */
1317
1318 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1319 static tree
1320 ffecom_make_complex_type_ (tree subtype)
1321 {
1322   tree type;
1323   tree realfield;
1324   tree imagfield;
1325
1326   if (ffe_is_emulate_complex ())
1327     {
1328       type = make_node (RECORD_TYPE);
1329       realfield = ffecom_decl_field (type, NULL_TREE, "r", subtype);
1330       imagfield = ffecom_decl_field (type, realfield, "i", subtype);
1331       TYPE_FIELDS (type) = realfield;
1332       layout_type (type);
1333     }
1334   else
1335     {
1336       type = make_node (COMPLEX_TYPE);
1337       TREE_TYPE (type) = subtype;
1338       layout_type (type);
1339     }
1340
1341   return type;
1342 }
1343 #endif
1344
1345 /* Chooses either the gbe or the f2c way to build a
1346    complex constant.  */
1347
1348 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1349 static tree
1350 ffecom_build_complex_constant_ (tree type, tree realpart, tree imagpart)
1351 {
1352   tree bothparts;
1353
1354   if (ffe_is_emulate_complex ())
1355     {
1356       bothparts = build_tree_list (TYPE_FIELDS (type), realpart);
1357       TREE_CHAIN (bothparts) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), imagpart);
1358       bothparts = build (CONSTRUCTOR, type, NULL_TREE, bothparts);
1359     }
1360   else
1361     {
1362       bothparts = build_complex (type, realpart, imagpart);
1363     }
1364
1365   return bothparts;
1366 }
1367 #endif
1368
1369 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1370 static tree
1371 ffecom_arglist_expr_ (const char *c, ffebld expr)
1372 {
1373   tree list;
1374   tree *plist = &list;
1375   tree trail = NULL_TREE;       /* Append char length args here. */
1376   tree *ptrail = &trail;
1377   tree length;
1378   ffebld exprh;
1379   tree item;
1380   bool ptr = FALSE;
1381   tree wanted = NULL_TREE;
1382   static char zed[] = "0";
1383
1384   if (c == NULL)
1385     c = &zed[0];
1386
1387   while (expr != NULL)
1388     {
1389       if (*c != '\0')
1390         {
1391           ptr = FALSE;
1392           if (*c == '&')
1393             {
1394               ptr = TRUE;
1395               ++c;
1396             }
1397           switch (*(c++))
1398             {
1399             case '\0':
1400               ptr = TRUE;
1401               wanted = NULL_TREE;
1402               break;
1403
1404             case 'a':
1405               assert (ptr);
1406               wanted = NULL_TREE;
1407               break;
1408
1409             case 'c':
1410               wanted = ffecom_f2c_complex_type_node;
1411               break;
1412
1413             case 'd':
1414               wanted = ffecom_f2c_doublereal_type_node;
1415               break;
1416
1417             case 'e':
1418               wanted = ffecom_f2c_doublecomplex_type_node;
1419               break;
1420
1421             case 'f':
1422               wanted = ffecom_f2c_real_type_node;
1423               break;
1424
1425             case 'i':
1426               wanted = ffecom_f2c_integer_type_node;
1427               break;
1428
1429             case 'j':
1430               wanted = ffecom_f2c_longint_type_node;
1431               break;
1432
1433             default:
1434               assert ("bad argstring code" == NULL);
1435               wanted = NULL_TREE;
1436               break;
1437             }
1438         }
1439
1440       exprh = ffebld_head (expr);
1441       if (exprh == NULL)
1442         wanted = NULL_TREE;
1443
1444       if ((wanted == NULL_TREE)
1445           || (ptr
1446               && (TYPE_MODE
1447                   (ffecom_tree_type[ffeinfo_basictype (ffebld_info (exprh))]
1448                    [ffeinfo_kindtype (ffebld_info (exprh))])
1449                    == TYPE_MODE (wanted))))
1450         *plist
1451           = build_tree_list (NULL_TREE,
1452                              ffecom_arg_ptr_to_expr (exprh,
1453                                                      &length));
1454       else
1455         {
1456           item = ffecom_arg_expr (exprh, &length);
1457           item = ffecom_convert_widen_ (wanted, item);
1458           if (ptr)
1459             {
1460               item = ffecom_1 (ADDR_EXPR,
1461                                build_pointer_type (TREE_TYPE (item)),
1462                                item);
1463             }
1464           *plist
1465             = build_tree_list (NULL_TREE,
1466                                item);
1467         }
1468
1469       plist = &TREE_CHAIN (*plist);
1470       expr = ffebld_trail (expr);
1471       if (length != NULL_TREE)
1472         {
1473           *ptrail = build_tree_list (NULL_TREE, length);
1474           ptrail = &TREE_CHAIN (*ptrail);
1475         }
1476     }
1477
1478   /* We've run out of args in the call; if the implementation expects
1479      more, supply null pointers for them, which the implementation can
1480      check to see if an arg was omitted. */
1481
1482   while (*c != '\0' && *c != '0')
1483     {
1484       if (*c == '&')
1485         ++c;
1486       else
1487         assert ("missing arg to run-time routine!" == NULL);
1488
1489       switch (*(c++))
1490         {
1491         case '\0':
1492         case 'a':
1493         case 'c':
1494         case 'd':
1495         case 'e':
1496         case 'f':
1497         case 'i':
1498         case 'j':
1499           break;
1500
1501         default:
1502           assert ("bad arg string code" == NULL);
1503           break;
1504         }
1505       *plist
1506         = build_tree_list (NULL_TREE,
1507                            null_pointer_node);
1508       plist = &TREE_CHAIN (*plist);
1509     }
1510
1511   *plist = trail;
1512
1513   return list;
1514 }
1515 #endif
1516
1517 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1518 static tree
1519 ffecom_widest_expr_type_ (ffebld list)
1520 {
1521   ffebld item;
1522   ffebld widest = NULL;
1523   ffetype type;
1524   ffetype widest_type = NULL;
1525   tree t;
1526
1527   for (; list != NULL; list = ffebld_trail (list))
1528     {
1529       item = ffebld_head (list);
1530       if (item == NULL)
1531         continue;
1532       if ((widest != NULL)
1533           && (ffeinfo_basictype (ffebld_info (item))
1534               != ffeinfo_basictype (ffebld_info (widest))))
1535         continue;
1536       type = ffeinfo_type (ffeinfo_basictype (ffebld_info (item)),
1537                            ffeinfo_kindtype (ffebld_info (item)));
1538       if ((widest == FFEINFO_kindtypeNONE)
1539           || (ffetype_size (type)
1540               > ffetype_size (widest_type)))
1541         {
1542           widest = item;
1543           widest_type = type;
1544         }
1545     }
1546
1547   assert (widest != NULL);
1548   t = ffecom_tree_type[ffeinfo_basictype (ffebld_info (widest))]
1549     [ffeinfo_kindtype (ffebld_info (widest))];
1550   assert (t != NULL_TREE);
1551   return t;
1552 }
1553 #endif
1554
1555 /* Check whether a partial overlap between two expressions is possible.
1556
1557    Can *starting* to write a portion of expr1 change the value
1558    computed (perhaps already, *partially*) by expr2?
1559
1560    Currently, this is a concern only for a COMPLEX expr1.  But if it
1561    isn't in COMMON or local EQUIVALENCE, since we don't support
1562    aliasing of arguments, it isn't a concern.  */
1563
1564 static bool
1565 ffecom_possible_partial_overlap_ (ffebld expr1, ffebld expr2 ATTRIBUTE_UNUSED)
1566 {
1567   ffesymbol sym;
1568   ffestorag st;
1569
1570   switch (ffebld_op (expr1))
1571     {
1572     case FFEBLD_opSYMTER:
1573       sym = ffebld_symter (expr1);
1574       break;
1575
1576     case FFEBLD_opARRAYREF:
1577       if (ffebld_op (ffebld_left (expr1)) != FFEBLD_opSYMTER)
1578         return FALSE;
1579       sym = ffebld_symter (ffebld_left (expr1));
1580       break;
1581
1582     default:
1583       return FALSE;
1584     }
1585
1586   if (ffesymbol_where (sym) != FFEINFO_whereCOMMON
1587       && (ffesymbol_where (sym) != FFEINFO_whereLOCAL
1588           || ! (st = ffesymbol_storage (sym))
1589           || ! ffestorag_parent (st)))
1590     return FALSE;
1591
1592   /* It's in COMMON or local EQUIVALENCE.  */
1593
1594   return TRUE;
1595 }
1596
1597 /* Check whether dest and source might overlap.  ffebld versions of these
1598    might or might not be passed, will be NULL if not.
1599
1600    The test is really whether source_tree is modifiable and, if modified,
1601    might overlap destination such that the value(s) in the destination might
1602    change before it is finally modified.  dest_* are the canonized
1603    destination itself.  */
1604
1605 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1606 static bool
1607 ffecom_overlap_ (tree dest_decl, tree dest_offset, tree dest_size,
1608                  tree source_tree, ffebld source UNUSED,
1609                  bool scalar_arg)
1610 {
1611   tree source_decl;
1612   tree source_offset;
1613   tree source_size;
1614   tree t;
1615
1616   if (source_tree == NULL_TREE)
1617     return FALSE;
1618
1619   switch (TREE_CODE (source_tree))
1620     {
1621     case ERROR_MARK:
1622     case IDENTIFIER_NODE:
1623     case INTEGER_CST:
1624     case REAL_CST:
1625     case COMPLEX_CST:
1626     case STRING_CST:
1627     case CONST_DECL:
1628     case VAR_DECL:
1629     case RESULT_DECL:
1630     case FIELD_DECL:
1631     case MINUS_EXPR:
1632     case MULT_EXPR:
1633     case TRUNC_DIV_EXPR:
1634     case CEIL_DIV_EXPR:
1635     case FLOOR_DIV_EXPR:
1636     case ROUND_DIV_EXPR:
1637     case TRUNC_MOD_EXPR:
1638     case CEIL_MOD_EXPR:
1639     case FLOOR_MOD_EXPR:
1640     case ROUND_MOD_EXPR:
1641     case RDIV_EXPR:
1642     case EXACT_DIV_EXPR:
1643     case FIX_TRUNC_EXPR:
1644     case FIX_CEIL_EXPR:
1645     case FIX_FLOOR_EXPR:
1646     case FIX_ROUND_EXPR:
1647     case FLOAT_EXPR:
1648     case EXPON_EXPR:
1649     case NEGATE_EXPR:
1650     case MIN_EXPR:
1651     case MAX_EXPR:
1652     case ABS_EXPR:
1653     case FFS_EXPR:
1654     case LSHIFT_EXPR:
1655     case RSHIFT_EXPR:
1656     case LROTATE_EXPR:
1657     case RROTATE_EXPR:
1658     case BIT_IOR_EXPR:
1659     case BIT_XOR_EXPR:
1660     case BIT_AND_EXPR:
1661     case BIT_ANDTC_EXPR:
1662     case BIT_NOT_EXPR:
1663     case TRUTH_ANDIF_EXPR:
1664     case TRUTH_ORIF_EXPR:
1665     case TRUTH_AND_EXPR:
1666     case TRUTH_OR_EXPR:
1667     case TRUTH_XOR_EXPR:
1668     case TRUTH_NOT_EXPR:
1669     case LT_EXPR:
1670     case LE_EXPR:
1671     case GT_EXPR:
1672     case GE_EXPR:
1673     case EQ_EXPR:
1674     case NE_EXPR:
1675     case COMPLEX_EXPR:
1676     case CONJ_EXPR:
1677     case REALPART_EXPR:
1678     case IMAGPART_EXPR:
1679     case LABEL_EXPR:
1680     case COMPONENT_REF:
1681       return FALSE;
1682
1683     case COMPOUND_EXPR:
1684       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1685                               TREE_OPERAND (source_tree, 1), NULL,
1686                               scalar_arg);
1687
1688     case MODIFY_EXPR:
1689       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1690                               TREE_OPERAND (source_tree, 0), NULL,
1691                               scalar_arg);
1692
1693     case CONVERT_EXPR:
1694     case NOP_EXPR:
1695     case NON_LVALUE_EXPR:
1696     case PLUS_EXPR:
1697       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1698         return TRUE;
1699
1700       ffecom_tree_canonize_ptr_ (&source_decl, &source_offset,
1701                                  source_tree);
1702       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1703       break;
1704
1705     case COND_EXPR:
1706       return
1707         ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1708                          TREE_OPERAND (source_tree, 1), NULL,
1709                          scalar_arg)
1710           || ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1711                               TREE_OPERAND (source_tree, 2), NULL,
1712                               scalar_arg);
1713
1714
1715     case ADDR_EXPR:
1716       ffecom_tree_canonize_ref_ (&source_decl, &source_offset,
1717                                  &source_size,
1718                                  TREE_OPERAND (source_tree, 0));
1719       break;
1720
1721     case PARM_DECL:
1722       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1723         return TRUE;
1724
1725       source_decl = source_tree;
1726       source_offset = bitsize_zero_node;
1727       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1728       break;
1729
1730     case SAVE_EXPR:
1731     case REFERENCE_EXPR:
1732     case PREDECREMENT_EXPR:
1733     case PREINCREMENT_EXPR:
1734     case POSTDECREMENT_EXPR:
1735     case POSTINCREMENT_EXPR:
1736     case INDIRECT_REF:
1737     case ARRAY_REF:
1738     case CALL_EXPR:
1739     default:
1740       return TRUE;
1741     }
1742
1743   /* Come here when source_decl, source_offset, and source_size filled
1744      in appropriately.  */
1745
1746   if (source_decl == NULL_TREE)
1747     return FALSE;               /* No decl involved, so no overlap. */
1748
1749   if (source_decl != dest_decl)
1750     return FALSE;               /* Different decl, no overlap. */
1751
1752   if (TREE_CODE (dest_size) == ERROR_MARK)
1753     return TRUE;                /* Assignment into entire assumed-size
1754                                    array?  Shouldn't happen.... */
1755
1756   t = ffecom_2 (LE_EXPR, integer_type_node,
1757                 ffecom_2 (PLUS_EXPR, TREE_TYPE (dest_offset),
1758                           dest_offset,
1759                           convert (TREE_TYPE (dest_offset),
1760                                    dest_size)),
1761                 convert (TREE_TYPE (dest_offset),
1762                          source_offset));
1763
1764   if (integer_onep (t))
1765     return FALSE;               /* Destination precedes source. */
1766
1767   if (!scalar_arg
1768       || (source_size == NULL_TREE)
1769       || (TREE_CODE (source_size) == ERROR_MARK)
1770       || integer_zerop (source_size))
1771     return TRUE;                /* No way to tell if dest follows source. */
1772
1773   t = ffecom_2 (LE_EXPR, integer_type_node,
1774                 ffecom_2 (PLUS_EXPR, TREE_TYPE (source_offset),
1775                           source_offset,
1776                           convert (TREE_TYPE (source_offset),
1777                                    source_size)),
1778                 convert (TREE_TYPE (source_offset),
1779                          dest_offset));
1780
1781   if (integer_onep (t))
1782     return FALSE;               /* Destination follows source. */
1783
1784   return TRUE;          /* Destination and source overlap. */
1785 }
1786 #endif
1787
1788 /* Check whether dest might overlap any of a list of arguments or is
1789    in a COMMON area the callee might know about (and thus modify).  */
1790
1791 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1792 static bool
1793 ffecom_args_overlapping_ (tree dest_tree, ffebld dest UNUSED,
1794                           tree args, tree callee_commons,
1795                           bool scalar_args)
1796 {
1797   tree arg;
1798   tree dest_decl;
1799   tree dest_offset;
1800   tree dest_size;
1801
1802   ffecom_tree_canonize_ref_ (&dest_decl, &dest_offset, &dest_size,
1803                              dest_tree);
1804
1805   if (dest_decl == NULL_TREE)
1806     return FALSE;               /* Seems unlikely! */
1807
1808   /* If the decl cannot be determined reliably, or if its in COMMON
1809      and the callee isn't known to not futz with COMMON via other
1810      means, overlap might happen.  */
1811
1812   if ((TREE_CODE (dest_decl) == ERROR_MARK)
1813       || ((callee_commons != NULL_TREE)
1814           && TREE_PUBLIC (dest_decl)))
1815     return TRUE;
1816
1817   for (; args != NULL_TREE; args = TREE_CHAIN (args))
1818     {
1819       if (((arg = TREE_VALUE (args)) != NULL_TREE)
1820           && ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1821                               arg, NULL, scalar_args))
1822         return TRUE;
1823     }
1824
1825   return FALSE;
1826 }
1827 #endif
1828
1829 /* Build a string for a variable name as used by NAMELIST.  This means that
1830    if we're using the f2c library, we build an uppercase string, since
1831    f2c does this.  */
1832
1833 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1834 static tree
1835 ffecom_build_f2c_string_ (int i, const char *s)
1836 {
1837   if (!ffe_is_f2c_library ())
1838     return build_string (i, s);
1839
1840   {
1841     char *tmp;
1842     const char *p;
1843     char *q;
1844     char space[34];
1845     tree t;
1846
1847     if (((size_t) i) > ARRAY_SIZE (space))
1848       tmp = malloc_new_ks (malloc_pool_image (), "f2c_string", i);
1849     else
1850       tmp = &space[0];
1851
1852     for (p = s, q = tmp; *p != '\0'; ++p, ++q)
1853       *q = ffesrc_toupper (*p);
1854     *q = '\0';
1855
1856     t = build_string (i, tmp);
1857
1858     if (((size_t) i) > ARRAY_SIZE (space))
1859       malloc_kill_ks (malloc_pool_image (), tmp, i);
1860
1861     return t;
1862   }
1863 }
1864
1865 #endif
1866 /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
1867    type to just get whatever the function returns), handling the
1868    f2c value-returning convention, if required, by prepending
1869    to the arglist a pointer to a temporary to receive the return value.  */
1870
1871 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1872 static tree
1873 ffecom_call_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1874               tree type, tree args, tree dest_tree,
1875               ffebld dest, bool *dest_used, tree callee_commons,
1876               bool scalar_args, tree hook)
1877 {
1878   tree item;
1879   tree tempvar;
1880
1881   if (dest_used != NULL)
1882     *dest_used = FALSE;
1883
1884   if (is_f2c_complex)
1885     {
1886       if ((dest_used == NULL)
1887           || (dest == NULL)
1888           || (ffeinfo_basictype (ffebld_info (dest))
1889               != FFEINFO_basictypeCOMPLEX)
1890           || (ffeinfo_kindtype (ffebld_info (dest)) != kt)
1891           || ((type != NULL_TREE) && (TREE_TYPE (dest_tree) != type))
1892           || ffecom_args_overlapping_ (dest_tree, dest, args,
1893                                        callee_commons,
1894                                        scalar_args))
1895         {
1896 #ifdef HOHO
1897           tempvar = ffecom_make_tempvar (ffecom_tree_type
1898                                          [FFEINFO_basictypeCOMPLEX][kt],
1899                                          FFETARGET_charactersizeNONE,
1900                                          -1);
1901 #else
1902           tempvar = hook;
1903           assert (tempvar);
1904 #endif
1905         }
1906       else
1907         {
1908           *dest_used = TRUE;
1909           tempvar = dest_tree;
1910           type = NULL_TREE;
1911         }
1912
1913       item
1914         = build_tree_list (NULL_TREE,
1915                            ffecom_1 (ADDR_EXPR,
1916                                      build_pointer_type (TREE_TYPE (tempvar)),
1917                                      tempvar));
1918       TREE_CHAIN (item) = args;
1919
1920       item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1921                         item, NULL_TREE);
1922
1923       if (tempvar != dest_tree)
1924         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item, tempvar);
1925     }
1926   else
1927     item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1928                       args, NULL_TREE);
1929
1930   if ((type != NULL_TREE) && (TREE_TYPE (item) != type))
1931     item = ffecom_convert_narrow_ (type, item);
1932
1933   return item;
1934 }
1935 #endif
1936
1937 /* Given two arguments, transform them and make a call to the given
1938    function via ffecom_call_.  */
1939
1940 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1941 static tree
1942 ffecom_call_binop_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1943                     tree type, ffebld left, ffebld right,
1944                     tree dest_tree, ffebld dest, bool *dest_used,
1945                     tree callee_commons, bool scalar_args, bool ref, tree hook)
1946 {
1947   tree left_tree;
1948   tree right_tree;
1949   tree left_length;
1950   tree right_length;
1951
1952   if (ref)
1953     {
1954       /* Pass arguments by reference.  */
1955       left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
1956       right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
1957     }
1958   else
1959     {
1960       /* Pass arguments by value.  */
1961       left_tree = ffecom_arg_expr (left, &left_length);
1962       right_tree = ffecom_arg_expr (right, &right_length);
1963     }
1964
1965
1966   left_tree = build_tree_list (NULL_TREE, left_tree);
1967   right_tree = build_tree_list (NULL_TREE, right_tree);
1968   TREE_CHAIN (left_tree) = right_tree;
1969
1970   if (left_length != NULL_TREE)
1971     {
1972       left_length = build_tree_list (NULL_TREE, left_length);
1973       TREE_CHAIN (right_tree) = left_length;
1974     }
1975
1976   if (right_length != NULL_TREE)
1977     {
1978       right_length = build_tree_list (NULL_TREE, right_length);
1979       if (left_length != NULL_TREE)
1980         TREE_CHAIN (left_length) = right_length;
1981       else
1982         TREE_CHAIN (right_tree) = right_length;
1983     }
1984
1985   return ffecom_call_ (fn, kt, is_f2c_complex, type, left_tree,
1986                        dest_tree, dest, dest_used, callee_commons,
1987                        scalar_args, hook);
1988 }
1989 #endif
1990
1991 /* Return ptr/length args for char subexpression
1992
1993    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
1994    subexpressions by constructing the appropriate trees for the ptr-to-
1995    character-text and length-of-character-text arguments in a calling
1996    sequence.
1997
1998    Note that if with_null is TRUE, and the expression is an opCONTER,
1999    a null byte is appended to the string.  */
2000
2001 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2002 static void
2003 ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null)
2004 {
2005   tree item;
2006   tree high;
2007   ffetargetCharacter1 val;
2008   ffetargetCharacterSize newlen;
2009
2010   switch (ffebld_op (expr))
2011     {
2012     case FFEBLD_opCONTER:
2013       val = ffebld_constant_character1 (ffebld_conter (expr));
2014       newlen = ffetarget_length_character1 (val);
2015       if (with_null)
2016         {
2017           /* Begin FFETARGET-NULL-KLUDGE.  */
2018           if (newlen != 0)
2019             ++newlen;
2020         }
2021       *length = build_int_2 (newlen, 0);
2022       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2023       high = build_int_2 (newlen, 0);
2024       TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
2025       item = build_string (newlen,
2026                            ffetarget_text_character1 (val));
2027       /* End FFETARGET-NULL-KLUDGE.  */
2028       TREE_TYPE (item)
2029         = build_type_variant
2030           (build_array_type
2031            (char_type_node,
2032             build_range_type
2033             (ffecom_f2c_ftnlen_type_node,
2034              ffecom_f2c_ftnlen_one_node,
2035              high)),
2036            1, 0);
2037       TREE_CONSTANT (item) = 1;
2038       TREE_STATIC (item) = 1;
2039       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
2040                        item);
2041       break;
2042
2043     case FFEBLD_opSYMTER:
2044       {
2045         ffesymbol s = ffebld_symter (expr);
2046
2047         item = ffesymbol_hook (s).decl_tree;
2048         if (item == NULL_TREE)
2049           {
2050             s = ffecom_sym_transform_ (s);
2051             item = ffesymbol_hook (s).decl_tree;
2052           }
2053         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
2054           {
2055             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
2056               *length = ffesymbol_hook (s).length_tree;
2057             else
2058               {
2059                 *length = build_int_2 (ffesymbol_size (s), 0);
2060                 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2061               }
2062           }
2063         else if (item == error_mark_node)
2064           *length = error_mark_node;
2065         else
2066           /* FFEINFO_kindFUNCTION.  */
2067           *length = NULL_TREE;
2068         if (!ffesymbol_hook (s).addr
2069             && (item != error_mark_node))
2070           item = ffecom_1 (ADDR_EXPR,
2071                            build_pointer_type (TREE_TYPE (item)),
2072                            item);
2073       }
2074       break;
2075
2076     case FFEBLD_opARRAYREF:
2077       {
2078         ffecom_char_args_ (&item, length, ffebld_left (expr));
2079
2080         if (item == error_mark_node || *length == error_mark_node)
2081           {
2082             item = *length = error_mark_node;
2083             break;
2084           }
2085
2086         item = ffecom_arrayref_ (item, expr, 1);
2087       }
2088       break;
2089
2090     case FFEBLD_opSUBSTR:
2091       {
2092         ffebld start;
2093         ffebld end;
2094         ffebld thing = ffebld_right (expr);
2095         tree start_tree;
2096         tree end_tree;
2097         const char *char_name;
2098         ffebld left_symter;
2099         tree array;
2100
2101         assert (ffebld_op (thing) == FFEBLD_opITEM);
2102         start = ffebld_head (thing);
2103         thing = ffebld_trail (thing);
2104         assert (ffebld_trail (thing) == NULL);
2105         end = ffebld_head (thing);
2106
2107         /* Determine name for pretty-printing range-check errors.  */
2108         for (left_symter = ffebld_left (expr);
2109              left_symter && ffebld_op (left_symter) == FFEBLD_opARRAYREF;
2110              left_symter = ffebld_left (left_symter))
2111           ;
2112         if (ffebld_op (left_symter) == FFEBLD_opSYMTER)
2113           char_name = ffesymbol_text (ffebld_symter (left_symter));
2114         else
2115           char_name = "[expr?]";
2116
2117         ffecom_char_args_ (&item, length, ffebld_left (expr));
2118
2119         if (item == error_mark_node || *length == error_mark_node)
2120           {
2121             item = *length = error_mark_node;
2122             break;
2123           }
2124
2125         array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
2126
2127         /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF.  */
2128
2129         if (start == NULL)
2130           {
2131             if (end == NULL)
2132               ;
2133             else
2134               {
2135                 end_tree = ffecom_expr (end);
2136                 if (flag_bounds_check)
2137                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2138                                                       char_name);
2139                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2140                                     end_tree);
2141
2142                 if (end_tree == error_mark_node)
2143                   {
2144                     item = *length = error_mark_node;
2145                     break;
2146                   }
2147
2148                 *length = end_tree;
2149               }
2150           }
2151         else
2152           {
2153             start_tree = ffecom_expr (start);
2154             if (flag_bounds_check)
2155               start_tree = ffecom_subscript_check_ (array, start_tree, 0, 0,
2156                                                     char_name);
2157             start_tree = convert (ffecom_f2c_ftnlen_type_node,
2158                                   start_tree);
2159
2160             if (start_tree == error_mark_node)
2161               {
2162                 item = *length = error_mark_node;
2163                 break;
2164               }
2165
2166             start_tree = ffecom_save_tree (start_tree);
2167
2168             item = ffecom_2 (PLUS_EXPR, TREE_TYPE (item),
2169                              item,
2170                              ffecom_2 (MINUS_EXPR,
2171                                        TREE_TYPE (start_tree),
2172                                        start_tree,
2173                                        ffecom_f2c_ftnlen_one_node));
2174
2175             if (end == NULL)
2176               {
2177                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2178                                     ffecom_f2c_ftnlen_one_node,
2179                                     ffecom_2 (MINUS_EXPR,
2180                                               ffecom_f2c_ftnlen_type_node,
2181                                               *length,
2182                                               start_tree));
2183               }
2184             else
2185               {
2186                 end_tree = ffecom_expr (end);
2187                 if (flag_bounds_check)
2188                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2189                                                       char_name);
2190                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2191                                     end_tree);
2192
2193                 if (end_tree == error_mark_node)
2194                   {
2195                     item = *length = error_mark_node;
2196                     break;
2197                   }
2198
2199                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2200                                     ffecom_f2c_ftnlen_one_node,
2201                                     ffecom_2 (MINUS_EXPR,
2202                                               ffecom_f2c_ftnlen_type_node,
2203                                               end_tree, start_tree));
2204               }
2205           }
2206       }
2207       break;
2208
2209     case FFEBLD_opFUNCREF:
2210       {
2211         ffesymbol s = ffebld_symter (ffebld_left (expr));
2212         tree tempvar;
2213         tree args;
2214         ffetargetCharacterSize size = ffeinfo_size (ffebld_info (expr));
2215         ffecomGfrt ix;
2216
2217         if (size == FFETARGET_charactersizeNONE)
2218           /* ~~Kludge alert!  This should someday be fixed. */
2219           size = 24;
2220
2221         *length = build_int_2 (size, 0);
2222         TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2223
2224         if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
2225             == FFEINFO_whereINTRINSIC)
2226           {
2227             if (size == 1)
2228               {
2229                 /* Invocation of an intrinsic returning CHARACTER*1.  */
2230                 item = ffecom_expr_intrinsic_ (expr, NULL_TREE,
2231                                                NULL, NULL);
2232                 break;
2233               }
2234             ix = ffeintrin_gfrt_direct (ffebld_symter_implementation (ffebld_left (expr)));
2235             assert (ix != FFECOM_gfrt);
2236             item = ffecom_gfrt_tree_ (ix);
2237           }
2238         else
2239           {
2240             ix = FFECOM_gfrt;
2241             item = ffesymbol_hook (s).decl_tree;
2242             if (item == NULL_TREE)
2243               {
2244                 s = ffecom_sym_transform_ (s);
2245                 item = ffesymbol_hook (s).decl_tree;
2246               }
2247             if (item == error_mark_node)
2248               {
2249                 item = *length = error_mark_node;
2250                 break;
2251               }
2252
2253             if (!ffesymbol_hook (s).addr)
2254               item = ffecom_1_fn (item);
2255           }
2256
2257 #ifdef HOHO
2258         tempvar = ffecom_push_tempvar (char_type_node, size, -1, TRUE);
2259 #else
2260         tempvar = ffebld_nonter_hook (expr);
2261         assert (tempvar);
2262 #endif
2263         tempvar = ffecom_1 (ADDR_EXPR,
2264                             build_pointer_type (TREE_TYPE (tempvar)),
2265                             tempvar);
2266
2267         args = build_tree_list (NULL_TREE, tempvar);
2268
2269         if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)       /* Sfunc args by value. */
2270           TREE_CHAIN (args) = ffecom_list_expr (ffebld_right (expr));
2271         else
2272           {
2273             TREE_CHAIN (args) = build_tree_list (NULL_TREE, *length);
2274             if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
2275               {
2276                 TREE_CHAIN (TREE_CHAIN (args))
2277                   = ffecom_arglist_expr_ (ffecom_gfrt_args_ (ix),
2278                                           ffebld_right (expr));
2279               }
2280             else
2281               {
2282                 TREE_CHAIN (TREE_CHAIN (args))
2283                   = ffecom_list_ptr_to_expr (ffebld_right (expr));
2284               }
2285           }
2286
2287         item = ffecom_3s (CALL_EXPR,
2288                           TREE_TYPE (TREE_TYPE (TREE_TYPE (item))),
2289                           item, args, NULL_TREE);
2290         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item,
2291                          tempvar);
2292       }
2293       break;
2294
2295     case FFEBLD_opCONVERT:
2296
2297       ffecom_char_args_ (&item, length, ffebld_left (expr));
2298
2299       if (item == error_mark_node || *length == error_mark_node)
2300         {
2301           item = *length = error_mark_node;
2302           break;
2303         }
2304
2305       if ((ffebld_size_known (ffebld_left (expr))
2306            == FFETARGET_charactersizeNONE)
2307           || (ffebld_size_known (ffebld_left (expr)) < (ffebld_size (expr))))
2308         {                       /* Possible blank-padding needed, copy into
2309                                    temporary. */
2310           tree tempvar;
2311           tree args;
2312           tree newlen;
2313
2314 #ifdef HOHO
2315           tempvar = ffecom_make_tempvar (char_type_node,
2316                                          ffebld_size (expr), -1);
2317 #else
2318           tempvar = ffebld_nonter_hook (expr);
2319           assert (tempvar);
2320 #endif
2321           tempvar = ffecom_1 (ADDR_EXPR,
2322                               build_pointer_type (TREE_TYPE (tempvar)),
2323                               tempvar);
2324
2325           newlen = build_int_2 (ffebld_size (expr), 0);
2326           TREE_TYPE (newlen) = ffecom_f2c_ftnlen_type_node;
2327
2328           args = build_tree_list (NULL_TREE, tempvar);
2329           TREE_CHAIN (args) = build_tree_list (NULL_TREE, item);
2330           TREE_CHAIN (TREE_CHAIN (args)) = build_tree_list (NULL_TREE, newlen);
2331           TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args)))
2332             = build_tree_list (NULL_TREE, *length);
2333
2334           item = ffecom_call_gfrt (FFECOM_gfrtCOPY, args, NULL_TREE);
2335           TREE_SIDE_EFFECTS (item) = 1;
2336           item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), fold (item),
2337                            tempvar);
2338           *length = newlen;
2339         }
2340       else
2341         {                       /* Just truncate the length. */
2342           *length = build_int_2 (ffebld_size (expr), 0);
2343           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2344         }
2345       break;
2346
2347     default:
2348       assert ("bad op for single char arg expr" == NULL);
2349       item = NULL_TREE;
2350       break;
2351     }
2352
2353   *xitem = item;
2354 }
2355 #endif
2356
2357 /* Check the size of the type to be sure it doesn't overflow the
2358    "portable" capacities of the compiler back end.  `dummy' types
2359    can generally overflow the normal sizes as long as the computations
2360    themselves don't overflow.  A particular target of the back end
2361    must still enforce its size requirements, though, and the back
2362    end takes care of this in stor-layout.c.  */
2363
2364 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2365 static tree
2366 ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy)
2367 {
2368   if (TREE_CODE (type) == ERROR_MARK)
2369     return type;
2370
2371   if (TYPE_SIZE (type) == NULL_TREE)
2372     return type;
2373
2374   if (TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST)
2375     return type;
2376
2377   if ((tree_int_cst_sgn (TYPE_SIZE (type)) < 0)
2378       || (!dummy && (((TREE_INT_CST_HIGH (TYPE_SIZE (type)) != 0))
2379                      || TREE_OVERFLOW (TYPE_SIZE (type)))))
2380     {
2381       ffebad_start (FFEBAD_ARRAY_LARGE);
2382       ffebad_string (ffesymbol_text (s));
2383       ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
2384       ffebad_finish ();
2385
2386       return error_mark_node;
2387     }
2388
2389   return type;
2390 }
2391 #endif
2392
2393 /* Builds a length argument (PARM_DECL).  Also wraps type in an array type
2394    where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
2395    known, length_arg if not known (FFETARGET_charactersizeNONE).  */
2396
2397 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2398 static tree
2399 ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s)
2400 {
2401   ffetargetCharacterSize sz = ffesymbol_size (s);
2402   tree highval;
2403   tree tlen;
2404   tree type = *xtype;
2405
2406   if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
2407     tlen = NULL_TREE;           /* A statement function, no length passed. */
2408   else
2409     {
2410       if (ffesymbol_where (s) == FFEINFO_whereDUMMY)
2411         tlen = ffecom_get_invented_identifier ("__g77_length_%s",
2412                                                ffesymbol_text (s));
2413       else
2414         tlen = ffecom_get_invented_identifier ("__g77_%s", "length");
2415       tlen = build_decl (PARM_DECL, tlen, ffecom_f2c_ftnlen_type_node);
2416 #if BUILT_FOR_270
2417       DECL_ARTIFICIAL (tlen) = 1;
2418 #endif
2419     }
2420
2421   if (sz == FFETARGET_charactersizeNONE)
2422     {
2423       assert (tlen != NULL_TREE);
2424       highval = variable_size (tlen);
2425     }
2426   else
2427     {
2428       highval = build_int_2 (sz, 0);
2429       TREE_TYPE (highval) = ffecom_f2c_ftnlen_type_node;
2430     }
2431
2432   type = build_array_type (type,
2433                            build_range_type (ffecom_f2c_ftnlen_type_node,
2434                                              ffecom_f2c_ftnlen_one_node,
2435                                              highval));
2436
2437   *xtype = type;
2438   return tlen;
2439 }
2440
2441 #endif
2442 /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
2443
2444    ffecomConcatList_ catlist;
2445    ffebld expr;  // expr of CHARACTER basictype.
2446    ffetargetCharacterSize max;  // max chars to gather or _...NONE if no max
2447    catlist = ffecom_concat_list_gather_(catlist,expr,max);
2448
2449    Scans expr for character subexpressions, updates and returns catlist
2450    accordingly.  */
2451
2452 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2453 static ffecomConcatList_
2454 ffecom_concat_list_gather_ (ffecomConcatList_ catlist, ffebld expr,
2455                             ffetargetCharacterSize max)
2456 {
2457   ffetargetCharacterSize sz;
2458
2459 recurse:                        /* :::::::::::::::::::: */
2460
2461   if (expr == NULL)
2462     return catlist;
2463
2464   if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen >= max))
2465     return catlist;             /* Don't append any more items. */
2466
2467   switch (ffebld_op (expr))
2468     {
2469     case FFEBLD_opCONTER:
2470     case FFEBLD_opSYMTER:
2471     case FFEBLD_opARRAYREF:
2472     case FFEBLD_opFUNCREF:
2473     case FFEBLD_opSUBSTR:
2474     case FFEBLD_opCONVERT:      /* Callers should strip this off beforehand
2475                                    if they don't need to preserve it. */
2476       if (catlist.count == catlist.max)
2477         {                       /* Make a (larger) list. */
2478           ffebld *newx;
2479           int newmax;
2480
2481           newmax = (catlist.max == 0) ? 8 : catlist.max * 2;
2482           newx = malloc_new_ks (malloc_pool_image (), "catlist",
2483                                 newmax * sizeof (newx[0]));
2484           if (catlist.max != 0)
2485             {
2486               memcpy (newx, catlist.exprs, catlist.max * sizeof (newx[0]));
2487               malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2488                               catlist.max * sizeof (newx[0]));
2489             }
2490           catlist.max = newmax;
2491           catlist.exprs = newx;
2492         }
2493       if ((sz = ffebld_size_known (expr)) != FFETARGET_charactersizeNONE)
2494         catlist.minlen += sz;
2495       else
2496         ++catlist.minlen;       /* Not true for F90; can be 0 length. */
2497       if ((sz = ffebld_size_max (expr)) == FFETARGET_charactersizeNONE)
2498         catlist.maxlen = sz;
2499       else
2500         catlist.maxlen += sz;
2501       if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen > max))
2502         {                       /* This item overlaps (or is beyond) the end
2503                                    of the destination. */
2504           switch (ffebld_op (expr))
2505             {
2506             case FFEBLD_opCONTER:
2507             case FFEBLD_opSYMTER:
2508             case FFEBLD_opARRAYREF:
2509             case FFEBLD_opFUNCREF:
2510             case FFEBLD_opSUBSTR:
2511               /* ~~Do useful truncations here. */
2512               break;
2513
2514             default:
2515               assert ("op changed or inconsistent switches!" == NULL);
2516               break;
2517             }
2518         }
2519       catlist.exprs[catlist.count++] = expr;
2520       return catlist;
2521
2522     case FFEBLD_opPAREN:
2523       expr = ffebld_left (expr);
2524       goto recurse;             /* :::::::::::::::::::: */
2525
2526     case FFEBLD_opCONCATENATE:
2527       catlist = ffecom_concat_list_gather_ (catlist, ffebld_left (expr), max);
2528       expr = ffebld_right (expr);
2529       goto recurse;             /* :::::::::::::::::::: */
2530
2531 #if 0                           /* Breaks passing small actual arg to larger
2532                                    dummy arg of sfunc */
2533     case FFEBLD_opCONVERT:
2534       expr = ffebld_left (expr);
2535       {
2536         ffetargetCharacterSize cmax;
2537
2538         cmax = catlist.len + ffebld_size_known (expr);
2539
2540         if ((max == FFETARGET_charactersizeNONE) || (max > cmax))
2541           max = cmax;
2542       }
2543       goto recurse;             /* :::::::::::::::::::: */
2544 #endif
2545
2546     case FFEBLD_opANY:
2547       return catlist;
2548
2549     default:
2550       assert ("bad op in _gather_" == NULL);
2551       return catlist;
2552     }
2553 }
2554
2555 #endif
2556 /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
2557
2558    ffecomConcatList_ catlist;
2559    ffecom_concat_list_kill_(catlist);
2560
2561    Anything allocated within the list info is deallocated.  */
2562
2563 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2564 static void
2565 ffecom_concat_list_kill_ (ffecomConcatList_ catlist)
2566 {
2567   if (catlist.max != 0)
2568     malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2569                     catlist.max * sizeof (catlist.exprs[0]));
2570 }
2571
2572 #endif
2573 /* Make list of concatenated string exprs.
2574
2575    Returns a flattened list of concatenated subexpressions given a
2576    tree of such expressions.  */
2577
2578 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2579 static ffecomConcatList_
2580 ffecom_concat_list_new_ (ffebld expr, ffetargetCharacterSize max)
2581 {
2582   ffecomConcatList_ catlist;
2583
2584   catlist.maxlen = catlist.minlen = catlist.max = catlist.count = 0;
2585   return ffecom_concat_list_gather_ (catlist, expr, max);
2586 }
2587
2588 #endif
2589
2590 /* Provide some kind of useful info on member of aggregate area,
2591    since current g77/gcc technology does not provide debug info
2592    on these members.  */
2593
2594 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2595 static void
2596 ffecom_debug_kludge_ (tree aggr, const char *aggr_type, ffesymbol member,
2597                       tree member_type UNUSED, ffetargetOffset offset)
2598 {
2599   tree value;
2600   tree decl;
2601   int len;
2602   char *buff;
2603   char space[120];
2604 #if 0
2605   tree type_id;
2606
2607   for (type_id = member_type;
2608        TREE_CODE (type_id) != IDENTIFIER_NODE;
2609        )
2610     {
2611       switch (TREE_CODE (type_id))
2612         {
2613         case INTEGER_TYPE:
2614         case REAL_TYPE:
2615           type_id = TYPE_NAME (type_id);
2616           break;
2617
2618         case ARRAY_TYPE:
2619         case COMPLEX_TYPE:
2620           type_id = TREE_TYPE (type_id);
2621           break;
2622
2623         default:
2624           assert ("no IDENTIFIER_NODE for type!" == NULL);
2625           type_id = error_mark_node;
2626           break;
2627         }
2628     }
2629 #endif
2630
2631   if (ffecom_transform_only_dummies_
2632       || !ffe_is_debug_kludge ())
2633     return;     /* Can't do this yet, maybe later. */
2634
2635   len = 60
2636     + strlen (aggr_type)
2637     + IDENTIFIER_LENGTH (DECL_NAME (aggr));
2638 #if 0
2639     + IDENTIFIER_LENGTH (type_id);
2640 #endif
2641
2642   if (((size_t) len) >= ARRAY_SIZE (space))
2643     buff = malloc_new_ks (malloc_pool_image (), "debug_kludge", len + 1);
2644   else
2645     buff = &space[0];
2646
2647   sprintf (&buff[0], "At (%s) `%s' plus %ld bytes",
2648            aggr_type,
2649            IDENTIFIER_POINTER (DECL_NAME (aggr)),
2650            (long int) offset);
2651
2652   value = build_string (len, buff);
2653   TREE_TYPE (value)
2654     = build_type_variant (build_array_type (char_type_node,
2655                                             build_range_type
2656                                             (integer_type_node,
2657                                              integer_one_node,
2658                                              build_int_2 (strlen (buff), 0))),
2659                           1, 0);
2660   decl = build_decl (VAR_DECL,
2661                      ffecom_get_identifier_ (ffesymbol_text (member)),
2662                      TREE_TYPE (value));
2663   TREE_CONSTANT (decl) = 1;
2664   TREE_STATIC (decl) = 1;
2665   DECL_INITIAL (decl) = error_mark_node;
2666   DECL_IN_SYSTEM_HEADER (decl) = 1;     /* Don't let -Wunused complain. */
2667   decl = start_decl (decl, FALSE);
2668   finish_decl (decl, value, FALSE);
2669
2670   if (buff != &space[0])
2671     malloc_kill_ks (malloc_pool_image (), buff, len + 1);
2672 }
2673 #endif
2674
2675 /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
2676
2677    ffesymbol fn;  // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
2678    int i;  // entry# for this entrypoint (used by master fn)
2679    ffecom_do_entrypoint_(s,i);
2680
2681    Makes a public entry point that calls our private master fn (already
2682    compiled).  */
2683
2684 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2685 static void
2686 ffecom_do_entry_ (ffesymbol fn, int entrynum)
2687 {
2688   ffebld item;
2689   tree type;                    /* Type of function. */
2690   tree multi_retval;            /* Var holding return value (union). */
2691   tree result;                  /* Var holding result. */
2692   ffeinfoBasictype bt;
2693   ffeinfoKindtype kt;
2694   ffeglobal g;
2695   ffeglobalType gt;
2696   bool charfunc;                /* All entry points return same type
2697                                    CHARACTER. */
2698   bool cmplxfunc;               /* Use f2c way of returning COMPLEX. */
2699   bool multi;                   /* Master fn has multiple return types. */
2700   bool altreturning = FALSE;    /* This entry point has alternate returns. */
2701   int yes;
2702   int old_lineno = lineno;
2703   const char *old_input_filename = input_filename;
2704
2705   input_filename = ffesymbol_where_filename (fn);
2706   lineno = ffesymbol_where_filelinenum (fn);
2707
2708   /* c-parse.y indeed does call suspend_momentary and not only ignores the
2709      return value, but also never calls resume_momentary, when starting an
2710      outer function (see "fndef:", "setspecs:", and so on).  So g77 does the
2711      same thing.  It shouldn't be a problem since start_function calls
2712      temporary_allocation, but it might be necessary.  If it causes a problem
2713      here, then maybe there's a bug lurking in gcc.  NOTE: This identical
2714      comment appears twice in thist file.  */
2715
2716   suspend_momentary ();
2717
2718   ffecom_doing_entry_ = TRUE;   /* Don't bother with array dimensions. */
2719
2720   switch (ffecom_primary_entry_kind_)
2721     {
2722     case FFEINFO_kindFUNCTION:
2723
2724       /* Determine actual return type for function. */
2725
2726       gt = FFEGLOBAL_typeFUNC;
2727       bt = ffesymbol_basictype (fn);
2728       kt = ffesymbol_kindtype (fn);
2729       if (bt == FFEINFO_basictypeNONE)
2730         {
2731           ffeimplic_establish_symbol (fn);
2732           if (ffesymbol_funcresult (fn) != NULL)
2733             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
2734           bt = ffesymbol_basictype (fn);
2735           kt = ffesymbol_kindtype (fn);
2736         }
2737
2738       if (bt == FFEINFO_basictypeCHARACTER)
2739         charfunc = TRUE, cmplxfunc = FALSE;
2740       else if ((bt == FFEINFO_basictypeCOMPLEX)
2741                && ffesymbol_is_f2c (fn))
2742         charfunc = FALSE, cmplxfunc = TRUE;
2743       else
2744         charfunc = cmplxfunc = FALSE;
2745
2746       if (charfunc)
2747         type = ffecom_tree_fun_type_void;
2748       else if (ffesymbol_is_f2c (fn))
2749         type = ffecom_tree_fun_type[bt][kt];
2750       else
2751         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
2752
2753       if ((type == NULL_TREE)
2754           || (TREE_TYPE (type) == NULL_TREE))
2755         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
2756
2757       multi = (ffecom_master_bt_ == FFEINFO_basictypeNONE);
2758       break;
2759
2760     case FFEINFO_kindSUBROUTINE:
2761       gt = FFEGLOBAL_typeSUBR;
2762       bt = FFEINFO_basictypeNONE;
2763       kt = FFEINFO_kindtypeNONE;
2764       if (ffecom_is_altreturning_)
2765         {                       /* Am _I_ altreturning? */
2766           for (item = ffesymbol_dummyargs (fn);
2767                item != NULL;
2768                item = ffebld_trail (item))
2769             {
2770               if (ffebld_op (ffebld_head (item)) == FFEBLD_opSTAR)
2771                 {
2772                   altreturning = TRUE;
2773                   break;
2774                 }
2775             }
2776           if (altreturning)
2777             type = ffecom_tree_subr_type;
2778           else
2779             type = ffecom_tree_fun_type_void;
2780         }
2781       else
2782         type = ffecom_tree_fun_type_void;
2783       charfunc = FALSE;
2784       cmplxfunc = FALSE;
2785       multi = FALSE;
2786       break;
2787
2788     default:
2789       assert ("say what??" == NULL);
2790       /* Fall through. */
2791     case FFEINFO_kindANY:
2792       gt = FFEGLOBAL_typeANY;
2793       bt = FFEINFO_basictypeNONE;
2794       kt = FFEINFO_kindtypeNONE;
2795       type = error_mark_node;
2796       charfunc = FALSE;
2797       cmplxfunc = FALSE;
2798       multi = FALSE;
2799       break;
2800     }
2801
2802   /* build_decl uses the current lineno and input_filename to set the decl
2803      source info.  So, I've putzed with ffestd and ffeste code to update that
2804      source info to point to the appropriate statement just before calling
2805      ffecom_do_entrypoint (which calls this fn).  */
2806
2807   start_function (ffecom_get_external_identifier_ (fn),
2808                   type,
2809                   0,            /* nested/inline */
2810                   1);           /* TREE_PUBLIC */
2811
2812   if (((g = ffesymbol_global (fn)) != NULL)
2813       && ((ffeglobal_type (g) == gt)
2814           || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
2815     {
2816       ffeglobal_set_hook (g, current_function_decl);
2817     }
2818
2819   /* Reset args in master arg list so they get retransitioned. */
2820
2821   for (item = ffecom_master_arglist_;
2822        item != NULL;
2823        item = ffebld_trail (item))
2824     {
2825       ffebld arg;
2826       ffesymbol s;
2827
2828       arg = ffebld_head (item);
2829       if (ffebld_op (arg) != FFEBLD_opSYMTER)
2830         continue;               /* Alternate return or some such thing. */
2831       s = ffebld_symter (arg);
2832       ffesymbol_hook (s).decl_tree = NULL_TREE;
2833       ffesymbol_hook (s).length_tree = NULL_TREE;
2834     }
2835
2836   /* Build dummy arg list for this entry point. */
2837
2838   yes = suspend_momentary ();
2839
2840   if (charfunc || cmplxfunc)
2841     {                           /* Prepend arg for where result goes. */
2842       tree type;
2843       tree length;
2844
2845       if (charfunc)
2846         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
2847       else
2848         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
2849
2850       result = ffecom_get_invented_identifier ("__g77_%s", "result");
2851
2852       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
2853
2854       if (charfunc)
2855         length = ffecom_char_enhance_arg_ (&type, fn);
2856       else
2857         length = NULL_TREE;     /* Not ref'd if !charfunc. */
2858
2859       type = build_pointer_type (type);
2860       result = build_decl (PARM_DECL, result, type);
2861
2862       push_parm_decl (result);
2863       ffecom_func_result_ = result;
2864
2865       if (charfunc)
2866         {
2867           push_parm_decl (length);
2868           ffecom_func_length_ = length;
2869         }
2870     }
2871   else
2872     result = DECL_RESULT (current_function_decl);
2873
2874   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn), FALSE);
2875
2876   resume_momentary (yes);
2877
2878   store_parm_decls (0);
2879
2880   ffecom_start_compstmt ();
2881   /* Disallow temp vars at this level.  */
2882   current_binding_level->prep_state = 2;
2883
2884   /* Make local var to hold return type for multi-type master fn. */
2885
2886   if (multi)
2887     {
2888       yes = suspend_momentary ();
2889
2890       multi_retval = ffecom_get_invented_identifier ("__g77_%s",
2891                                                      "multi_retval");
2892       multi_retval = build_decl (VAR_DECL, multi_retval,
2893                                  ffecom_multi_type_node_);
2894       multi_retval = start_decl (multi_retval, FALSE);
2895       finish_decl (multi_retval, NULL_TREE, FALSE);
2896
2897       resume_momentary (yes);
2898     }
2899   else
2900     multi_retval = NULL_TREE;   /* Not actually ref'd if !multi. */
2901
2902   /* Here we emit the actual code for the entry point. */
2903
2904   {
2905     ffebld list;
2906     ffebld arg;
2907     ffesymbol s;
2908     tree arglist = NULL_TREE;
2909     tree *plist = &arglist;
2910     tree prepend;
2911     tree call;
2912     tree actarg;
2913     tree master_fn;
2914
2915     /* Prepare actual arg list based on master arg list. */
2916
2917     for (list = ffecom_master_arglist_;
2918          list != NULL;
2919          list = ffebld_trail (list))
2920       {
2921         arg = ffebld_head (list);
2922         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2923           continue;
2924         s = ffebld_symter (arg);
2925         if (ffesymbol_hook (s).decl_tree == NULL_TREE
2926             || ffesymbol_hook (s).decl_tree == error_mark_node)
2927           actarg = null_pointer_node;   /* We don't have this arg. */
2928         else
2929           actarg = ffesymbol_hook (s).decl_tree;
2930         *plist = build_tree_list (NULL_TREE, actarg);
2931         plist = &TREE_CHAIN (*plist);
2932       }
2933
2934     /* This code appends the length arguments for character
2935        variables/arrays.  */
2936
2937     for (list = ffecom_master_arglist_;
2938          list != NULL;
2939          list = ffebld_trail (list))
2940       {
2941         arg = ffebld_head (list);
2942         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2943           continue;
2944         s = ffebld_symter (arg);
2945         if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
2946           continue;             /* Only looking for CHARACTER arguments. */
2947         if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
2948           continue;             /* Only looking for variables and arrays. */
2949         if (ffesymbol_hook (s).length_tree == NULL_TREE
2950             || ffesymbol_hook (s).length_tree == error_mark_node)
2951           actarg = ffecom_f2c_ftnlen_zero_node; /* We don't have this arg. */
2952         else
2953           actarg = ffesymbol_hook (s).length_tree;
2954         *plist = build_tree_list (NULL_TREE, actarg);
2955         plist = &TREE_CHAIN (*plist);
2956       }
2957
2958     /* Prepend character-value return info to actual arg list. */
2959
2960     if (charfunc)
2961       {
2962         prepend = build_tree_list (NULL_TREE, ffecom_func_result_);
2963         TREE_CHAIN (prepend)
2964           = build_tree_list (NULL_TREE, ffecom_func_length_);
2965         TREE_CHAIN (TREE_CHAIN (prepend)) = arglist;
2966         arglist = prepend;
2967       }
2968
2969     /* Prepend multi-type return value to actual arg list. */
2970
2971     if (multi)
2972       {
2973         prepend
2974           = build_tree_list (NULL_TREE,
2975                              ffecom_1 (ADDR_EXPR,
2976                               build_pointer_type (TREE_TYPE (multi_retval)),
2977                                        multi_retval));
2978         TREE_CHAIN (prepend) = arglist;
2979         arglist = prepend;
2980       }
2981
2982     /* Prepend my entry-point number to the actual arg list. */
2983
2984     prepend = build_tree_list (NULL_TREE, build_int_2 (entrynum, 0));
2985     TREE_CHAIN (prepend) = arglist;
2986     arglist = prepend;
2987
2988     /* Build the call to the master function. */
2989
2990     master_fn = ffecom_1_fn (ffecom_previous_function_decl_);
2991     call = ffecom_3s (CALL_EXPR,
2992                       TREE_TYPE (TREE_TYPE (TREE_TYPE (master_fn))),
2993                       master_fn, arglist, NULL_TREE);
2994
2995     /* Decide whether the master function is a function or subroutine, and
2996        handle the return value for my entry point. */
2997
2998     if (charfunc || ((ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
2999                      && !altreturning))
3000       {
3001         expand_expr_stmt (call);
3002         expand_null_return ();
3003       }
3004     else if (multi && cmplxfunc)
3005       {
3006         expand_expr_stmt (call);
3007         result
3008           = ffecom_1 (INDIRECT_REF,
3009                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
3010                       result);
3011         result = ffecom_modify (NULL_TREE, result,
3012                                 ffecom_2 (COMPONENT_REF, TREE_TYPE (result),
3013                                           multi_retval,
3014                                           ffecom_multi_fields_[bt][kt]));
3015         expand_expr_stmt (result);
3016         expand_null_return ();
3017       }
3018     else if (multi)
3019       {
3020         expand_expr_stmt (call);
3021         result
3022           = ffecom_modify (NULL_TREE, result,
3023                            convert (TREE_TYPE (result),
3024                                     ffecom_2 (COMPONENT_REF,
3025                                               ffecom_tree_type[bt][kt],
3026                                               multi_retval,
3027                                               ffecom_multi_fields_[bt][kt])));
3028         expand_return (result);
3029       }
3030     else if (cmplxfunc)
3031       {
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, call);
3037         expand_expr_stmt (result);
3038         expand_null_return ();
3039       }
3040     else
3041       {
3042         result = ffecom_modify (NULL_TREE,
3043                                 result,
3044                                 convert (TREE_TYPE (result),
3045                                          call));
3046         expand_return (result);
3047       }
3048
3049     clear_momentary ();
3050   }
3051
3052   ffecom_end_compstmt ();
3053
3054   finish_function (0);
3055
3056   lineno = old_lineno;
3057   input_filename = old_input_filename;
3058
3059   ffecom_doing_entry_ = FALSE;
3060 }
3061
3062 #endif
3063 /* Transform expr into gcc tree with possible destination
3064
3065    Recursive descent on expr while making corresponding tree nodes and
3066    attaching type info and such.  If destination supplied and compatible
3067    with temporary that would be made in certain cases, temporary isn't
3068    made, destination used instead, and dest_used flag set TRUE.  */
3069
3070 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3071 static tree
3072 ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
3073               bool *dest_used, bool assignp, bool widenp)
3074 {
3075   tree item;
3076   tree list;
3077   tree args;
3078   ffeinfoBasictype bt;
3079   ffeinfoKindtype kt;
3080   tree t;
3081   tree dt;                      /* decl_tree for an ffesymbol. */
3082   tree tree_type, tree_type_x;
3083   tree left, right;
3084   ffesymbol s;
3085   enum tree_code code;
3086
3087   assert (expr != NULL);
3088
3089   if (dest_used != NULL)
3090     *dest_used = FALSE;
3091
3092   bt = ffeinfo_basictype (ffebld_info (expr));
3093   kt = ffeinfo_kindtype (ffebld_info (expr));
3094   tree_type = ffecom_tree_type[bt][kt];
3095
3096   /* Widen integral arithmetic as desired while preserving signedness.  */
3097   tree_type_x = NULL_TREE;
3098   if (widenp && tree_type
3099       && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
3100       && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
3101     tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
3102
3103   switch (ffebld_op (expr))
3104     {
3105     case FFEBLD_opACCTER:
3106       {
3107         ffebitCount i;
3108         ffebit bits = ffebld_accter_bits (expr);
3109         ffetargetOffset source_offset = 0;
3110         ffetargetOffset dest_offset = ffebld_accter_pad (expr);
3111         tree purpose;
3112
3113         assert (dest_offset == 0
3114                 || (bt == FFEINFO_basictypeCHARACTER
3115                     && kt == FFEINFO_kindtypeCHARACTER1));
3116
3117         list = item = NULL;
3118         for (;;)
3119           {
3120             ffebldConstantUnion cu;
3121             ffebitCount length;
3122             bool value;
3123             ffebldConstantArray ca = ffebld_accter (expr);
3124
3125             ffebit_test (bits, source_offset, &value, &length);
3126             if (length == 0)
3127               break;
3128
3129             if (value)
3130               {
3131                 for (i = 0; i < length; ++i)
3132                   {
3133                     cu = ffebld_constantarray_get (ca, bt, kt,
3134                                                    source_offset + i);
3135
3136                     t = ffecom_constantunion (&cu, bt, kt, tree_type);
3137
3138                     if (i == 0
3139                         && dest_offset != 0)
3140                       purpose = build_int_2 (dest_offset, 0);
3141                     else
3142                       purpose = NULL_TREE;
3143
3144                     if (list == NULL_TREE)
3145                       list = item = build_tree_list (purpose, t);
3146                     else
3147                       {
3148                         TREE_CHAIN (item) = build_tree_list (purpose, t);
3149                         item = TREE_CHAIN (item);
3150                       }
3151                   }
3152               }
3153             source_offset += length;
3154             dest_offset += length;
3155           }
3156       }
3157
3158       item = build_int_2 ((ffebld_accter_size (expr)
3159                            + ffebld_accter_pad (expr)) - 1, 0);
3160       ffebit_kill (ffebld_accter_bits (expr));
3161       TREE_TYPE (item) = ffecom_integer_type_node;
3162       item
3163         = build_array_type
3164           (tree_type,
3165            build_range_type (ffecom_integer_type_node,
3166                              ffecom_integer_zero_node,
3167                              item));
3168       list = build (CONSTRUCTOR, item, NULL_TREE, list);
3169       TREE_CONSTANT (list) = 1;
3170       TREE_STATIC (list) = 1;
3171       return list;
3172
3173     case FFEBLD_opARRTER:
3174       {
3175         ffetargetOffset i;
3176
3177         list = NULL_TREE;
3178         if (ffebld_arrter_pad (expr) == 0)
3179           item = NULL_TREE;
3180         else
3181           {
3182             assert (bt == FFEINFO_basictypeCHARACTER
3183                     && kt == FFEINFO_kindtypeCHARACTER1);
3184
3185             /* Becomes PURPOSE first time through loop.  */
3186             item = build_int_2 (ffebld_arrter_pad (expr), 0);
3187           }
3188
3189         for (i = 0; i < ffebld_arrter_size (expr); ++i)
3190           {
3191             ffebldConstantUnion cu
3192             = ffebld_constantarray_get (ffebld_arrter (expr), bt, kt, i);
3193
3194             t = ffecom_constantunion (&cu, bt, kt, tree_type);
3195
3196             if (list == NULL_TREE)
3197               /* Assume item is PURPOSE first time through loop.  */
3198               list = item = build_tree_list (item, t);
3199             else
3200               {
3201                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
3202                 item = TREE_CHAIN (item);
3203               }
3204           }
3205       }
3206
3207       item = build_int_2 ((ffebld_arrter_size (expr)
3208                           + ffebld_arrter_pad (expr)) - 1, 0);
3209       TREE_TYPE (item) = ffecom_integer_type_node;
3210       item
3211         = build_array_type
3212           (tree_type,
3213            build_range_type (ffecom_integer_type_node,
3214                              ffecom_integer_zero_node,
3215                              item));
3216       list = build (CONSTRUCTOR, item, NULL_TREE, list);
3217       TREE_CONSTANT (list) = 1;
3218       TREE_STATIC (list) = 1;
3219       return list;
3220
3221     case FFEBLD_opCONTER:
3222       assert (ffebld_conter_pad (expr) == 0);
3223       item
3224         = ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr)),
3225                                 bt, kt, tree_type);
3226       return item;
3227
3228     case FFEBLD_opSYMTER:
3229       if ((ffebld_symter_generic (expr) != FFEINTRIN_genNONE)
3230           || (ffebld_symter_specific (expr) != FFEINTRIN_specNONE))
3231         return ffecom_ptr_to_expr (expr);       /* Same as %REF(intrinsic). */
3232       s = ffebld_symter (expr);
3233       t = ffesymbol_hook (s).decl_tree;
3234
3235       if (assignp)
3236         {                       /* ASSIGN'ed-label expr. */
3237           if (ffe_is_ugly_assign ())
3238             {
3239               /* User explicitly wants ASSIGN'ed variables to be at the same
3240                  memory address as the variables when used in non-ASSIGN
3241                  contexts.  That can make old, arcane, non-standard code
3242                  work, but don't try to do it when a pointer wouldn't fit
3243                  in the normal variable (take other approach, and warn,
3244                  instead).  */
3245
3246               if (t == NULL_TREE)
3247                 {
3248                   s = ffecom_sym_transform_ (s);
3249                   t = ffesymbol_hook (s).decl_tree;
3250                   assert (t != NULL_TREE);
3251                 }
3252
3253               if (t == error_mark_node)
3254                 return t;
3255
3256               if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t)))
3257                   >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
3258                 {
3259                   if (ffesymbol_hook (s).addr)
3260                     t = ffecom_1 (INDIRECT_REF,
3261                                   TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3262                   return t;
3263                 }
3264
3265               if (ffesymbol_hook (s).assign_tree == NULL_TREE)
3266                 {
3267                   ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling",
3268                                     FFEBAD_severityWARNING);
3269                   ffebad_string (ffesymbol_text (s));
3270                   ffebad_here (0, ffesymbol_where_line (s),
3271                                ffesymbol_where_column (s));
3272                   ffebad_finish ();
3273                 }
3274             }
3275
3276           /* Don't use the normal variable's tree for ASSIGN, though mark
3277              it as in the system header (housekeeping).  Use an explicit,
3278              specially created sibling that is known to be wide enough
3279              to hold pointers to labels.  */
3280
3281           if (t != NULL_TREE
3282               && TREE_CODE (t) == VAR_DECL)
3283             DECL_IN_SYSTEM_HEADER (t) = 1;      /* Don't let -Wunused complain. */
3284
3285           t = ffesymbol_hook (s).assign_tree;
3286           if (t == NULL_TREE)
3287             {
3288               s = ffecom_sym_transform_assign_ (s);
3289               t = ffesymbol_hook (s).assign_tree;
3290               assert (t != NULL_TREE);
3291             }
3292         }
3293       else
3294         {
3295           if (t == NULL_TREE)
3296             {
3297               s = ffecom_sym_transform_ (s);
3298               t = ffesymbol_hook (s).decl_tree;
3299               assert (t != NULL_TREE);
3300             }
3301           if (ffesymbol_hook (s).addr)
3302             t = ffecom_1 (INDIRECT_REF,
3303                           TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3304         }
3305       return t;
3306
3307     case FFEBLD_opARRAYREF:
3308       return ffecom_arrayref_ (NULL_TREE, expr, 0);
3309
3310     case FFEBLD_opUPLUS:
3311       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3312       return ffecom_1 (NOP_EXPR, tree_type, left);
3313
3314     case FFEBLD_opPAREN:
3315       /* ~~~Make sure Fortran rules respected here */
3316       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3317       return ffecom_1 (NOP_EXPR, tree_type, left);
3318
3319     case FFEBLD_opUMINUS:
3320       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3321       if (tree_type_x)
3322         {
3323           tree_type = tree_type_x;
3324           left = convert (tree_type, left);
3325         }
3326       return ffecom_1 (NEGATE_EXPR, tree_type, left);
3327
3328     case FFEBLD_opADD:
3329       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3330       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3331       if (tree_type_x)
3332         {
3333           tree_type = tree_type_x;
3334           left = convert (tree_type, left);
3335           right = convert (tree_type, right);
3336         }
3337       return ffecom_2 (PLUS_EXPR, tree_type, left, right);
3338
3339     case FFEBLD_opSUBTRACT:
3340       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3341       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3342       if (tree_type_x)
3343         {
3344           tree_type = tree_type_x;
3345           left = convert (tree_type, left);
3346           right = convert (tree_type, right);
3347         }
3348       return ffecom_2 (MINUS_EXPR, tree_type, left, right);
3349
3350     case FFEBLD_opMULTIPLY:
3351       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3352       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3353       if (tree_type_x)
3354         {
3355           tree_type = tree_type_x;
3356           left = convert (tree_type, left);
3357           right = convert (tree_type, right);
3358         }
3359       return ffecom_2 (MULT_EXPR, tree_type, left, right);
3360
3361     case FFEBLD_opDIVIDE:
3362       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3363       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3364       if (tree_type_x)
3365         {
3366           tree_type = tree_type_x;
3367           left = convert (tree_type, left);
3368           right = convert (tree_type, right);
3369         }
3370       return ffecom_tree_divide_ (tree_type, left, right,
3371                                   dest_tree, dest, dest_used,
3372                                   ffebld_nonter_hook (expr));
3373
3374     case FFEBLD_opPOWER:
3375       {
3376         ffebld left = ffebld_left (expr);
3377         ffebld right = ffebld_right (expr);
3378         ffecomGfrt code;
3379         ffeinfoKindtype rtkt;
3380         ffeinfoKindtype ltkt;
3381         bool ref = TRUE;
3382
3383         switch (ffeinfo_basictype (ffebld_info (right)))
3384           {
3385
3386           case FFEINFO_basictypeINTEGER:
3387             if (1 || optimize)
3388               {
3389                 item = ffecom_expr_power_integer_ (expr);
3390                 if (item != NULL_TREE)
3391                   return item;
3392               }
3393
3394             rtkt = FFEINFO_kindtypeINTEGER1;
3395             switch (ffeinfo_basictype (ffebld_info (left)))
3396               {
3397               case FFEINFO_basictypeINTEGER:
3398                 if ((ffeinfo_kindtype (ffebld_info (left))
3399                     == FFEINFO_kindtypeINTEGER4)
3400                     || (ffeinfo_kindtype (ffebld_info (right))
3401                         == FFEINFO_kindtypeINTEGER4))
3402                   {
3403                     code = FFECOM_gfrtPOW_QQ;
3404                     ltkt = FFEINFO_kindtypeINTEGER4;
3405                     rtkt = FFEINFO_kindtypeINTEGER4;
3406                   }
3407                 else
3408                   {
3409                     code = FFECOM_gfrtPOW_II;
3410                     ltkt = FFEINFO_kindtypeINTEGER1;
3411                   }
3412                 break;
3413
3414               case FFEINFO_basictypeREAL:
3415                 if (ffeinfo_kindtype (ffebld_info (left))
3416                     == FFEINFO_kindtypeREAL1)
3417                   {
3418                     code = FFECOM_gfrtPOW_RI;
3419                     ltkt = FFEINFO_kindtypeREAL1;
3420                   }
3421                 else
3422                   {
3423                     code = FFECOM_gfrtPOW_DI;
3424                     ltkt = FFEINFO_kindtypeREAL2;
3425                   }
3426                 break;
3427
3428               case FFEINFO_basictypeCOMPLEX:
3429                 if (ffeinfo_kindtype (ffebld_info (left))
3430                     == FFEINFO_kindtypeREAL1)
3431                   {
3432                     code = FFECOM_gfrtPOW_CI;   /* Overlapping result okay. */
3433                     ltkt = FFEINFO_kindtypeREAL1;
3434                   }
3435                 else
3436                   {
3437                     code = FFECOM_gfrtPOW_ZI;   /* Overlapping result okay. */
3438                     ltkt = FFEINFO_kindtypeREAL2;
3439                   }
3440                 break;
3441
3442               default:
3443                 assert ("bad pow_*i" == NULL);
3444                 code = FFECOM_gfrtPOW_CI;       /* Overlapping result okay. */
3445                 ltkt = FFEINFO_kindtypeREAL1;
3446                 break;
3447               }
3448             if (ffeinfo_kindtype (ffebld_info (left)) != ltkt)
3449               left = ffeexpr_convert (left, NULL, NULL,
3450                                       ffeinfo_basictype (ffebld_info (left)),
3451                                       ltkt, 0,
3452                                       FFETARGET_charactersizeNONE,
3453                                       FFEEXPR_contextLET);
3454             if (ffeinfo_kindtype (ffebld_info (right)) != rtkt)
3455               right = ffeexpr_convert (right, NULL, NULL,
3456                                        FFEINFO_basictypeINTEGER,
3457                                        rtkt, 0,
3458                                        FFETARGET_charactersizeNONE,
3459                                        FFEEXPR_contextLET);
3460             break;
3461
3462           case FFEINFO_basictypeREAL:
3463             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3464               left = ffeexpr_convert (left, NULL, NULL, FFEINFO_basictypeREAL,
3465                                       FFEINFO_kindtypeREALDOUBLE, 0,
3466                                       FFETARGET_charactersizeNONE,
3467                                       FFEEXPR_contextLET);
3468             if (ffeinfo_kindtype (ffebld_info (right))
3469                 == FFEINFO_kindtypeREAL1)
3470               right = ffeexpr_convert (right, NULL, NULL,
3471                                        FFEINFO_basictypeREAL,
3472                                        FFEINFO_kindtypeREALDOUBLE, 0,
3473                                        FFETARGET_charactersizeNONE,
3474                                        FFEEXPR_contextLET);
3475             /* We used to call FFECOM_gfrtPOW_DD here,
3476                which passes arguments by reference.  */
3477             code = FFECOM_gfrtL_POW;
3478             /* Pass arguments by value. */
3479             ref  = FALSE;
3480             break;
3481
3482           case FFEINFO_basictypeCOMPLEX:
3483             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3484               left = ffeexpr_convert (left, NULL, NULL,
3485                                       FFEINFO_basictypeCOMPLEX,
3486                                       FFEINFO_kindtypeREALDOUBLE, 0,
3487                                       FFETARGET_charactersizeNONE,
3488                                       FFEEXPR_contextLET);
3489             if (ffeinfo_kindtype (ffebld_info (right))
3490                 == FFEINFO_kindtypeREAL1)
3491               right = ffeexpr_convert (right, NULL, NULL,
3492                                        FFEINFO_basictypeCOMPLEX,
3493                                        FFEINFO_kindtypeREALDOUBLE, 0,
3494                                        FFETARGET_charactersizeNONE,
3495                                        FFEEXPR_contextLET);
3496             code = FFECOM_gfrtPOW_ZZ;   /* Overlapping result okay. */
3497             ref = TRUE;                 /* Pass arguments by reference. */
3498             break;
3499
3500           default:
3501             assert ("bad pow_x*" == NULL);
3502             code = FFECOM_gfrtPOW_II;
3503             break;
3504           }
3505         return ffecom_call_binop_ (ffecom_gfrt_tree_ (code),
3506                                    ffecom_gfrt_kindtype (code),
3507                                    (ffe_is_f2c_library ()
3508                                     && ffecom_gfrt_complex_[code]),
3509                                    tree_type, left, right,
3510                                    dest_tree, dest, dest_used,
3511                                    NULL_TREE, FALSE, ref,
3512                                    ffebld_nonter_hook (expr));
3513       }
3514
3515     case FFEBLD_opNOT:
3516       switch (bt)
3517         {
3518         case FFEINFO_basictypeLOGICAL:
3519           item = ffecom_truth_value_invert (ffecom_expr (ffebld_left (expr)));
3520           return convert (tree_type, item);
3521
3522         case FFEINFO_basictypeINTEGER:
3523           return ffecom_1 (BIT_NOT_EXPR, tree_type,
3524                            ffecom_expr (ffebld_left (expr)));
3525
3526         default:
3527           assert ("NOT bad basictype" == NULL);
3528           /* Fall through. */
3529         case FFEINFO_basictypeANY:
3530           return error_mark_node;
3531         }
3532       break;
3533
3534     case FFEBLD_opFUNCREF:
3535       assert (ffeinfo_basictype (ffebld_info (expr))
3536               != FFEINFO_basictypeCHARACTER);
3537       /* Fall through.   */
3538     case FFEBLD_opSUBRREF:
3539       if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
3540           == FFEINFO_whereINTRINSIC)
3541         {                       /* Invocation of an intrinsic. */
3542           item = ffecom_expr_intrinsic_ (expr, dest_tree, dest,
3543                                          dest_used);
3544           return item;
3545         }
3546       s = ffebld_symter (ffebld_left (expr));
3547       dt = ffesymbol_hook (s).decl_tree;
3548       if (dt == NULL_TREE)
3549         {
3550           s = ffecom_sym_transform_ (s);
3551           dt = ffesymbol_hook (s).decl_tree;
3552         }
3553       if (dt == error_mark_node)
3554         return dt;
3555
3556       if (ffesymbol_hook (s).addr)
3557         item = dt;
3558       else
3559         item = ffecom_1_fn (dt);
3560
3561       if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
3562         args = ffecom_list_expr (ffebld_right (expr));
3563       else
3564         args = ffecom_list_ptr_to_expr (ffebld_right (expr));
3565
3566       if (args == error_mark_node)
3567         return error_mark_node;
3568
3569       item = ffecom_call_ (item, kt,
3570                            ffesymbol_is_f2c (s)
3571                            && (bt == FFEINFO_basictypeCOMPLEX)
3572                            && (ffesymbol_where (s)
3573                                != FFEINFO_whereCONSTANT),
3574                            tree_type,
3575                            args,
3576                            dest_tree, dest, dest_used,
3577                            error_mark_node, FALSE,
3578                            ffebld_nonter_hook (expr));
3579       TREE_SIDE_EFFECTS (item) = 1;
3580       return item;
3581
3582     case FFEBLD_opAND:
3583       switch (bt)
3584         {
3585         case FFEINFO_basictypeLOGICAL:
3586           item
3587             = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3588                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3589                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3590           return convert (tree_type, item);
3591
3592         case FFEINFO_basictypeINTEGER:
3593           return ffecom_2 (BIT_AND_EXPR, tree_type,
3594                            ffecom_expr (ffebld_left (expr)),
3595                            ffecom_expr (ffebld_right (expr)));
3596
3597         default:
3598           assert ("AND bad basictype" == NULL);
3599           /* Fall through. */
3600         case FFEINFO_basictypeANY:
3601           return error_mark_node;
3602         }
3603       break;
3604
3605     case FFEBLD_opOR:
3606       switch (bt)
3607         {
3608         case FFEINFO_basictypeLOGICAL:
3609           item
3610             = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
3611                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3612                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3613           return convert (tree_type, item);
3614
3615         case FFEINFO_basictypeINTEGER:
3616           return ffecom_2 (BIT_IOR_EXPR, tree_type,
3617                            ffecom_expr (ffebld_left (expr)),
3618                            ffecom_expr (ffebld_right (expr)));
3619
3620         default:
3621           assert ("OR bad basictype" == NULL);
3622           /* Fall through. */
3623         case FFEINFO_basictypeANY:
3624           return error_mark_node;
3625         }
3626       break;
3627
3628     case FFEBLD_opXOR:
3629     case FFEBLD_opNEQV:
3630       switch (bt)
3631         {
3632         case FFEINFO_basictypeLOGICAL:
3633           item
3634             = ffecom_2 (NE_EXPR, integer_type_node,
3635                         ffecom_expr (ffebld_left (expr)),
3636                         ffecom_expr (ffebld_right (expr)));
3637           return convert (tree_type, ffecom_truth_value (item));
3638
3639         case FFEINFO_basictypeINTEGER:
3640           return ffecom_2 (BIT_XOR_EXPR, tree_type,
3641                            ffecom_expr (ffebld_left (expr)),
3642                            ffecom_expr (ffebld_right (expr)));
3643
3644         default:
3645           assert ("XOR/NEQV bad basictype" == NULL);
3646           /* Fall through. */
3647         case FFEINFO_basictypeANY:
3648           return error_mark_node;
3649         }
3650       break;
3651
3652     case FFEBLD_opEQV:
3653       switch (bt)
3654         {
3655         case FFEINFO_basictypeLOGICAL:
3656           item
3657             = ffecom_2 (EQ_EXPR, integer_type_node,
3658                         ffecom_expr (ffebld_left (expr)),
3659                         ffecom_expr (ffebld_right (expr)));
3660           return convert (tree_type, ffecom_truth_value (item));
3661
3662         case FFEINFO_basictypeINTEGER:
3663           return
3664             ffecom_1 (BIT_NOT_EXPR, tree_type,
3665                       ffecom_2 (BIT_XOR_EXPR, tree_type,
3666                                 ffecom_expr (ffebld_left (expr)),
3667                                 ffecom_expr (ffebld_right (expr))));
3668
3669         default:
3670           assert ("EQV bad basictype" == NULL);
3671           /* Fall through. */
3672         case FFEINFO_basictypeANY:
3673           return error_mark_node;
3674         }
3675       break;
3676
3677     case FFEBLD_opCONVERT:
3678       if (ffebld_op (ffebld_left (expr)) == FFEBLD_opANY)
3679         return error_mark_node;
3680
3681       switch (bt)
3682         {
3683         case FFEINFO_basictypeLOGICAL:
3684         case FFEINFO_basictypeINTEGER:
3685         case FFEINFO_basictypeREAL:
3686           return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3687
3688         case FFEINFO_basictypeCOMPLEX:
3689           switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3690             {
3691             case FFEINFO_basictypeINTEGER:
3692             case FFEINFO_basictypeLOGICAL:
3693             case FFEINFO_basictypeREAL:
3694               item = ffecom_expr (ffebld_left (expr));
3695               if (item == error_mark_node)
3696                 return error_mark_node;
3697               /* convert() takes care of converting to the subtype first,
3698                  at least in gcc-2.7.2. */
3699               item = convert (tree_type, item);
3700               return item;
3701
3702             case FFEINFO_basictypeCOMPLEX:
3703               return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3704
3705             default:
3706               assert ("CONVERT COMPLEX bad basictype" == NULL);
3707               /* Fall through. */
3708             case FFEINFO_basictypeANY:
3709               return error_mark_node;
3710             }
3711           break;
3712
3713         default:
3714           assert ("CONVERT bad basictype" == NULL);
3715           /* Fall through. */
3716         case FFEINFO_basictypeANY:
3717           return error_mark_node;
3718         }
3719       break;
3720
3721     case FFEBLD_opLT:
3722       code = LT_EXPR;
3723       goto relational;          /* :::::::::::::::::::: */
3724
3725     case FFEBLD_opLE:
3726       code = LE_EXPR;
3727       goto relational;          /* :::::::::::::::::::: */
3728
3729     case FFEBLD_opEQ:
3730       code = EQ_EXPR;
3731       goto relational;          /* :::::::::::::::::::: */
3732
3733     case FFEBLD_opNE:
3734       code = NE_EXPR;
3735       goto relational;          /* :::::::::::::::::::: */
3736
3737     case FFEBLD_opGT:
3738       code = GT_EXPR;
3739       goto relational;          /* :::::::::::::::::::: */
3740
3741     case FFEBLD_opGE:
3742       code = GE_EXPR;
3743
3744     relational:         /* :::::::::::::::::::: */
3745       switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3746         {
3747         case FFEINFO_basictypeLOGICAL:
3748         case FFEINFO_basictypeINTEGER:
3749         case FFEINFO_basictypeREAL:
3750           item = ffecom_2 (code, integer_type_node,
3751                            ffecom_expr (ffebld_left (expr)),
3752                            ffecom_expr (ffebld_right (expr)));
3753           return convert (tree_type, item);
3754
3755         case FFEINFO_basictypeCOMPLEX:
3756           assert (code == EQ_EXPR || code == NE_EXPR);
3757           {
3758             tree real_type;
3759             tree arg1 = ffecom_expr (ffebld_left (expr));
3760             tree arg2 = ffecom_expr (ffebld_right (expr));
3761
3762             if (arg1 == error_mark_node || arg2 == error_mark_node)
3763               return error_mark_node;
3764
3765             arg1 = ffecom_save_tree (arg1);
3766             arg2 = ffecom_save_tree (arg2);
3767
3768             if (TREE_CODE (TREE_TYPE (arg1)) == COMPLEX_TYPE)
3769               {
3770                 real_type = TREE_TYPE (TREE_TYPE (arg1));
3771                 assert (real_type == TREE_TYPE (TREE_TYPE (arg2)));
3772               }
3773             else
3774               {
3775                 real_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg1)));
3776                 assert (real_type == TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg2))));
3777               }
3778
3779             item
3780               = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3781                           ffecom_2 (EQ_EXPR, integer_type_node,
3782                                   ffecom_1 (REALPART_EXPR, real_type, arg1),
3783                                  ffecom_1 (REALPART_EXPR, real_type, arg2)),
3784                           ffecom_2 (EQ_EXPR, integer_type_node,
3785                                   ffecom_1 (IMAGPART_EXPR, real_type, arg1),
3786                                     ffecom_1 (IMAGPART_EXPR, real_type,
3787                                               arg2)));
3788             if (code == EQ_EXPR)
3789               item = ffecom_truth_value (item);
3790             else
3791               item = ffecom_truth_value_invert (item);
3792             return convert (tree_type, item);
3793           }
3794
3795         case FFEINFO_basictypeCHARACTER:
3796           {
3797             ffebld left = ffebld_left (expr);
3798             ffebld right = ffebld_right (expr);
3799             tree left_tree;
3800             tree right_tree;
3801             tree left_length;
3802             tree right_length;
3803
3804             /* f2c run-time functions do the implicit blank-padding for us,
3805                so we don't usually have to implement blank-padding ourselves.
3806                (The exception is when we pass an argument to a separately
3807                compiled statement function -- if we know the arg is not the
3808                same length as the dummy, we must truncate or extend it.  If
3809                we "inline" statement functions, that necessity goes away as
3810                well.)
3811
3812                Strip off the CONVERT operators that blank-pad.  (Truncation by
3813                CONVERT shouldn't happen here, but it can happen in
3814                assignments.) */
3815
3816             while (ffebld_op (left) == FFEBLD_opCONVERT)
3817               left = ffebld_left (left);
3818             while (ffebld_op (right) == FFEBLD_opCONVERT)
3819               right = ffebld_left (right);
3820
3821             left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
3822             right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
3823
3824             if (left_tree == error_mark_node || left_length == error_mark_node
3825                 || right_tree == error_mark_node
3826                 || right_length == error_mark_node)
3827               return error_mark_node;
3828
3829             if ((ffebld_size_known (left) == 1)
3830                 && (ffebld_size_known (right) == 1))
3831               {
3832                 left_tree
3833                   = ffecom_1 (INDIRECT_REF,
3834                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3835                               left_tree);
3836                 right_tree
3837                   = ffecom_1 (INDIRECT_REF,
3838                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3839                               right_tree);
3840
3841                 item
3842                   = ffecom_2 (code, integer_type_node,
3843                               ffecom_2 (ARRAY_REF,
3844                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3845                                         left_tree,
3846                                         integer_one_node),
3847                               ffecom_2 (ARRAY_REF,
3848                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3849                                         right_tree,
3850                                         integer_one_node));
3851               }
3852             else
3853               {
3854                 item = build_tree_list (NULL_TREE, left_tree);
3855                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, right_tree);
3856                 TREE_CHAIN (TREE_CHAIN (item)) = build_tree_list (NULL_TREE,
3857                                                                left_length);
3858                 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
3859                   = build_tree_list (NULL_TREE, right_length);
3860                 item = ffecom_call_gfrt (FFECOM_gfrtCMP, item, NULL_TREE);
3861                 item = ffecom_2 (code, integer_type_node,
3862                                  item,
3863                                  convert (TREE_TYPE (item),
3864                                           integer_zero_node));
3865               }
3866             item = convert (tree_type, item);
3867           }
3868
3869           return item;
3870
3871         default:
3872           assert ("relational bad basictype" == NULL);
3873           /* Fall through. */
3874         case FFEINFO_basictypeANY:
3875           return error_mark_node;
3876         }
3877       break;
3878
3879     case FFEBLD_opPERCENT_LOC:
3880       item = ffecom_arg_ptr_to_expr (ffebld_left (expr), &list);
3881       return convert (tree_type, item);
3882
3883     case FFEBLD_opITEM:
3884     case FFEBLD_opSTAR:
3885     case FFEBLD_opBOUNDS:
3886     case FFEBLD_opREPEAT:
3887     case FFEBLD_opLABTER:
3888     case FFEBLD_opLABTOK:
3889     case FFEBLD_opIMPDO:
3890     case FFEBLD_opCONCATENATE:
3891     case FFEBLD_opSUBSTR:
3892     default:
3893       assert ("bad op" == NULL);
3894       /* Fall through. */
3895     case FFEBLD_opANY:
3896       return error_mark_node;
3897     }
3898
3899 #if 1
3900   assert ("didn't think anything got here anymore!!" == NULL);
3901 #else
3902   switch (ffebld_arity (expr))
3903     {
3904     case 2:
3905       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3906       TREE_OPERAND (item, 1) = ffecom_expr (ffebld_right (expr));
3907       if (TREE_OPERAND (item, 0) == error_mark_node
3908           || TREE_OPERAND (item, 1) == error_mark_node)
3909         return error_mark_node;
3910       break;
3911
3912     case 1:
3913       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3914       if (TREE_OPERAND (item, 0) == error_mark_node)
3915         return error_mark_node;
3916       break;
3917
3918     default:
3919       break;
3920     }
3921
3922   return fold (item);
3923 #endif
3924 }
3925
3926 #endif
3927 /* Returns the tree that does the intrinsic invocation.
3928
3929    Note: this function applies only to intrinsics returning
3930    CHARACTER*1 or non-CHARACTER results, and to intrinsic
3931    subroutines.  */
3932
3933 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3934 static tree
3935 ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
3936                         ffebld dest, bool *dest_used)
3937 {
3938   tree expr_tree;
3939   tree saved_expr1;             /* For those who need it. */
3940   tree saved_expr2;             /* For those who need it. */
3941   ffeinfoBasictype bt;
3942   ffeinfoKindtype kt;
3943   tree tree_type;
3944   tree arg1_type;
3945   tree real_type;               /* REAL type corresponding to COMPLEX. */
3946   tree tempvar;
3947   ffebld list = ffebld_right (expr);    /* List of (some) args. */
3948   ffebld arg1;                  /* For handy reference. */
3949   ffebld arg2;
3950   ffebld arg3;
3951   ffeintrinImp codegen_imp;
3952   ffecomGfrt gfrt;
3953
3954   assert (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER);
3955
3956   if (dest_used != NULL)
3957     *dest_used = FALSE;
3958
3959   bt = ffeinfo_basictype (ffebld_info (expr));
3960   kt = ffeinfo_kindtype (ffebld_info (expr));
3961   tree_type = ffecom_tree_type[bt][kt];
3962
3963   if (list != NULL)
3964     {
3965       arg1 = ffebld_head (list);
3966       if (arg1 != NULL && ffebld_op (arg1) == FFEBLD_opANY)
3967         return error_mark_node;
3968       if ((list = ffebld_trail (list)) != NULL)
3969         {
3970           arg2 = ffebld_head (list);
3971           if (arg2 != NULL && ffebld_op (arg2) == FFEBLD_opANY)
3972             return error_mark_node;
3973           if ((list = ffebld_trail (list)) != NULL)
3974             {
3975               arg3 = ffebld_head (list);
3976               if (arg3 != NULL && ffebld_op (arg3) == FFEBLD_opANY)
3977                 return error_mark_node;
3978             }
3979           else
3980             arg3 = NULL;
3981         }
3982       else
3983         arg2 = arg3 = NULL;
3984     }
3985   else
3986     arg1 = arg2 = arg3 = NULL;
3987
3988   /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
3989      args.  This is used by the MAX/MIN expansions. */
3990
3991   if (arg1 != NULL)
3992     arg1_type = ffecom_tree_type
3993       [ffeinfo_basictype (ffebld_info (arg1))]
3994       [ffeinfo_kindtype (ffebld_info (arg1))];
3995   else
3996     arg1_type = NULL_TREE;      /* Really not needed, but might catch bugs
3997                                    here. */
3998
3999   /* There are several ways for each of the cases in the following switch
4000      statements to exit (from simplest to use to most complicated):
4001
4002      break;  (when expr_tree == NULL)
4003
4004      A standard call is made to the specific intrinsic just as if it had been
4005      passed in as a dummy procedure and called as any old procedure.  This
4006      method can produce slower code but in some cases it's the easiest way for
4007      now.  However, if a (presumably faster) direct call is available,
4008      that is used, so this is the easiest way in many more cases now.
4009
4010      gfrt = FFECOM_gfrtWHATEVER;
4011      break;
4012
4013      gfrt contains the gfrt index of a library function to call, passing the
4014      argument(s) by value rather than by reference.  Used when a more
4015      careful choice of library function is needed than that provided
4016      by the vanilla `break;'.
4017
4018      return expr_tree;
4019
4020      The expr_tree has been completely set up and is ready to be returned
4021      as is.  No further actions are taken.  Use this when the tree is not
4022      in the simple form for one of the arity_n labels.   */
4023
4024   /* For info on how the switch statement cases were written, see the files
4025      enclosed in comments below the switch statement. */
4026
4027   codegen_imp = ffebld_symter_implementation (ffebld_left (expr));
4028   gfrt = ffeintrin_gfrt_direct (codegen_imp);
4029   if (gfrt == FFECOM_gfrt)
4030     gfrt = ffeintrin_gfrt_indirect (codegen_imp);
4031
4032   switch (codegen_imp)
4033     {
4034     case FFEINTRIN_impABS:
4035     case FFEINTRIN_impCABS:
4036     case FFEINTRIN_impCDABS:
4037     case FFEINTRIN_impDABS:
4038     case FFEINTRIN_impIABS:
4039       if (ffeinfo_basictype (ffebld_info (arg1))
4040           == FFEINFO_basictypeCOMPLEX)
4041         {
4042           if (kt == FFEINFO_kindtypeREAL1)
4043             gfrt = FFECOM_gfrtCABS;
4044           else if (kt == FFEINFO_kindtypeREAL2)
4045             gfrt = FFECOM_gfrtCDABS;
4046           break;
4047         }
4048       return ffecom_1 (ABS_EXPR, tree_type,
4049                        convert (tree_type, ffecom_expr (arg1)));
4050
4051     case FFEINTRIN_impACOS:
4052     case FFEINTRIN_impDACOS:
4053       break;
4054
4055     case FFEINTRIN_impAIMAG:
4056     case FFEINTRIN_impDIMAG:
4057     case FFEINTRIN_impIMAGPART:
4058       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
4059         arg1_type = TREE_TYPE (arg1_type);
4060       else
4061         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
4062
4063       return
4064         convert (tree_type,
4065                  ffecom_1 (IMAGPART_EXPR, arg1_type,
4066                            ffecom_expr (arg1)));
4067
4068     case FFEINTRIN_impAINT:
4069     case FFEINTRIN_impDINT:
4070 #if 0
4071       /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg.  */
4072       return ffecom_1 (FIX_TRUNC_EXPR, tree_type, ffecom_expr (arg1));
4073 #else /* in the meantime, must use floor to avoid range problems with ints */
4074       /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
4075       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4076       return
4077         convert (tree_type,
4078                  ffecom_3 (COND_EXPR, double_type_node,
4079                            ffecom_truth_value
4080                            (ffecom_2 (GE_EXPR, integer_type_node,
4081                                       saved_expr1,
4082                                       convert (arg1_type,
4083                                                ffecom_float_zero_))),
4084                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4085                                              build_tree_list (NULL_TREE,
4086                                                   convert (double_type_node,
4087                                                            saved_expr1)),
4088                                              NULL_TREE),
4089                            ffecom_1 (NEGATE_EXPR, double_type_node,
4090                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4091                                                  build_tree_list (NULL_TREE,
4092                                                   convert (double_type_node,
4093                                                       ffecom_1 (NEGATE_EXPR,
4094                                                                 arg1_type,
4095                                                                saved_expr1))),
4096                                                        NULL_TREE)
4097                                      ))
4098                  );
4099 #endif
4100
4101     case FFEINTRIN_impANINT:
4102     case FFEINTRIN_impDNINT:
4103 #if 0                           /* This way of doing it won't handle real
4104                                    numbers of large magnitudes. */
4105       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4106       expr_tree = convert (tree_type,
4107                            convert (integer_type_node,
4108                                     ffecom_3 (COND_EXPR, tree_type,
4109                                               ffecom_truth_value
4110                                               (ffecom_2 (GE_EXPR,
4111                                                          integer_type_node,
4112                                                          saved_expr1,
4113                                                        ffecom_float_zero_)),
4114                                               ffecom_2 (PLUS_EXPR,
4115                                                         tree_type,
4116                                                         saved_expr1,
4117                                                         ffecom_float_half_),
4118                                               ffecom_2 (MINUS_EXPR,
4119                                                         tree_type,
4120                                                         saved_expr1,
4121                                                      ffecom_float_half_))));
4122       return expr_tree;
4123 #else /* So we instead call floor. */
4124       /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
4125       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4126       return
4127         convert (tree_type,
4128                  ffecom_3 (COND_EXPR, double_type_node,
4129                            ffecom_truth_value
4130                            (ffecom_2 (GE_EXPR, integer_type_node,
4131                                       saved_expr1,
4132                                       convert (arg1_type,
4133                                                ffecom_float_zero_))),
4134                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4135                                              build_tree_list (NULL_TREE,
4136                                                   convert (double_type_node,
4137                                                            ffecom_2 (PLUS_EXPR,
4138                                                                      arg1_type,
4139                                                                      saved_expr1,
4140                                                                      convert (arg1_type,
4141                                                                               ffecom_float_half_)))),
4142                                              NULL_TREE),
4143                            ffecom_1 (NEGATE_EXPR, double_type_node,
4144                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4145                                                        build_tree_list (NULL_TREE,
4146                                                                         convert (double_type_node,
4147                                                                                  ffecom_2 (MINUS_EXPR,
4148                                                                                            arg1_type,
4149                                                                                            convert (arg1_type,
4150                                                                                                     ffecom_float_half_),
4151                                                                                            saved_expr1))),
4152                                                        NULL_TREE))
4153                            )
4154                  );
4155 #endif
4156
4157     case FFEINTRIN_impASIN:
4158     case FFEINTRIN_impDASIN:
4159     case FFEINTRIN_impATAN:
4160     case FFEINTRIN_impDATAN:
4161     case FFEINTRIN_impATAN2:
4162     case FFEINTRIN_impDATAN2:
4163       break;
4164
4165     case FFEINTRIN_impCHAR:
4166     case FFEINTRIN_impACHAR:
4167 #ifdef HOHO
4168       tempvar = ffecom_make_tempvar (char_type_node, 1, -1);
4169 #else
4170       tempvar = ffebld_nonter_hook (expr);
4171       assert (tempvar);
4172 #endif
4173       {
4174         tree tmv = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar)));
4175
4176         expr_tree = ffecom_modify (tmv,
4177                                    ffecom_2 (ARRAY_REF, tmv, tempvar,
4178                                              integer_one_node),
4179                                    convert (tmv, ffecom_expr (arg1)));
4180       }
4181       expr_tree = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar),
4182                             expr_tree,
4183                             tempvar);
4184       expr_tree = ffecom_1 (ADDR_EXPR,
4185                             build_pointer_type (TREE_TYPE (expr_tree)),
4186                             expr_tree);
4187       return expr_tree;
4188
4189     case FFEINTRIN_impCMPLX:
4190     case FFEINTRIN_impDCMPLX:
4191       if (arg2 == NULL)
4192         return
4193           convert (tree_type, ffecom_expr (arg1));
4194
4195       real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4196       return
4197         ffecom_2 (COMPLEX_EXPR, tree_type,
4198                   convert (real_type, ffecom_expr (arg1)),
4199                   convert (real_type,
4200                            ffecom_expr (arg2)));
4201
4202     case FFEINTRIN_impCOMPLEX:
4203       return
4204         ffecom_2 (COMPLEX_EXPR, tree_type,
4205                   ffecom_expr (arg1),
4206                   ffecom_expr (arg2));
4207
4208     case FFEINTRIN_impCONJG:
4209     case FFEINTRIN_impDCONJG:
4210       {
4211         tree arg1_tree;
4212
4213         real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4214         arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4215         return
4216           ffecom_2 (COMPLEX_EXPR, tree_type,
4217                     ffecom_1 (REALPART_EXPR, real_type, arg1_tree),
4218                     ffecom_1 (NEGATE_EXPR, real_type,
4219                               ffecom_1 (IMAGPART_EXPR, real_type, arg1_tree)));
4220       }
4221
4222     case FFEINTRIN_impCOS:
4223     case FFEINTRIN_impCCOS:
4224     case FFEINTRIN_impCDCOS:
4225     case FFEINTRIN_impDCOS:
4226       if (bt == FFEINFO_basictypeCOMPLEX)
4227         {
4228           if (kt == FFEINFO_kindtypeREAL1)
4229             gfrt = FFECOM_gfrtCCOS;     /* Overlapping result okay. */
4230           else if (kt == FFEINFO_kindtypeREAL2)
4231             gfrt = FFECOM_gfrtCDCOS;    /* Overlapping result okay. */
4232         }
4233       break;
4234
4235     case FFEINTRIN_impCOSH:
4236     case FFEINTRIN_impDCOSH:
4237       break;
4238
4239     case FFEINTRIN_impDBLE:
4240     case FFEINTRIN_impDFLOAT:
4241     case FFEINTRIN_impDREAL:
4242     case FFEINTRIN_impFLOAT:
4243     case FFEINTRIN_impIDINT:
4244     case FFEINTRIN_impIFIX:
4245     case FFEINTRIN_impINT2:
4246     case FFEINTRIN_impINT8:
4247     case FFEINTRIN_impINT:
4248     case FFEINTRIN_impLONG:
4249     case FFEINTRIN_impREAL:
4250     case FFEINTRIN_impSHORT:
4251     case FFEINTRIN_impSNGL:
4252       return convert (tree_type, ffecom_expr (arg1));
4253
4254     case FFEINTRIN_impDIM:
4255     case FFEINTRIN_impDDIM:
4256     case FFEINTRIN_impIDIM:
4257       saved_expr1 = ffecom_save_tree (convert (tree_type,
4258                                                ffecom_expr (arg1)));
4259       saved_expr2 = ffecom_save_tree (convert (tree_type,
4260                                                ffecom_expr (arg2)));
4261       return
4262         ffecom_3 (COND_EXPR, tree_type,
4263                   ffecom_truth_value
4264                   (ffecom_2 (GT_EXPR, integer_type_node,
4265                              saved_expr1,
4266                              saved_expr2)),
4267                   ffecom_2 (MINUS_EXPR, tree_type,
4268                             saved_expr1,
4269                             saved_expr2),
4270                   convert (tree_type, ffecom_float_zero_));
4271
4272     case FFEINTRIN_impDPROD:
4273       return
4274         ffecom_2 (MULT_EXPR, tree_type,
4275                   convert (tree_type, ffecom_expr (arg1)),
4276                   convert (tree_type, ffecom_expr (arg2)));
4277
4278     case FFEINTRIN_impEXP:
4279     case FFEINTRIN_impCDEXP:
4280     case FFEINTRIN_impCEXP:
4281     case FFEINTRIN_impDEXP:
4282       if (bt == FFEINFO_basictypeCOMPLEX)
4283         {
4284           if (kt == FFEINFO_kindtypeREAL1)
4285             gfrt = FFECOM_gfrtCEXP;     /* Overlapping result okay. */
4286           else if (kt == FFEINFO_kindtypeREAL2)
4287             gfrt = FFECOM_gfrtCDEXP;    /* Overlapping result okay. */
4288         }
4289       break;
4290
4291     case FFEINTRIN_impICHAR:
4292     case FFEINTRIN_impIACHAR:
4293 #if 0                           /* The simple approach. */
4294       ffecom_char_args_ (&expr_tree, &saved_expr1 /* Ignored */ , arg1);
4295       expr_tree
4296         = ffecom_1 (INDIRECT_REF,
4297                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4298                     expr_tree);
4299       expr_tree
4300         = ffecom_2 (ARRAY_REF,
4301                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4302                     expr_tree,
4303                     integer_one_node);
4304       return convert (tree_type, expr_tree);
4305 #else /* The more interesting (and more optimal) approach. */
4306       expr_tree = ffecom_intrinsic_ichar_ (tree_type, arg1, &saved_expr1);
4307       expr_tree = ffecom_3 (COND_EXPR, tree_type,
4308                             saved_expr1,
4309                             expr_tree,
4310                             convert (tree_type, integer_zero_node));
4311       return expr_tree;
4312 #endif
4313
4314     case FFEINTRIN_impINDEX:
4315       break;
4316
4317     case FFEINTRIN_impLEN:
4318 #if 0
4319       break;                                    /* The simple approach. */
4320 #else
4321       return ffecom_intrinsic_len_ (arg1);      /* The more optimal approach. */
4322 #endif
4323
4324     case FFEINTRIN_impLGE:
4325     case FFEINTRIN_impLGT:
4326     case FFEINTRIN_impLLE:
4327     case FFEINTRIN_impLLT:
4328       break;
4329
4330     case FFEINTRIN_impLOG:
4331     case FFEINTRIN_impALOG:
4332     case FFEINTRIN_impCDLOG:
4333     case FFEINTRIN_impCLOG:
4334     case FFEINTRIN_impDLOG:
4335       if (bt == FFEINFO_basictypeCOMPLEX)
4336         {
4337           if (kt == FFEINFO_kindtypeREAL1)
4338             gfrt = FFECOM_gfrtCLOG;     /* Overlapping result okay. */
4339           else if (kt == FFEINFO_kindtypeREAL2)
4340             gfrt = FFECOM_gfrtCDLOG;    /* Overlapping result okay. */
4341         }
4342       break;
4343
4344     case FFEINTRIN_impLOG10:
4345     case FFEINTRIN_impALOG10:
4346     case FFEINTRIN_impDLOG10:
4347       if (gfrt != FFECOM_gfrt)
4348         break;  /* Already picked one, stick with it. */
4349
4350       if (kt == FFEINFO_kindtypeREAL1)
4351         /* We used to call FFECOM_gfrtALOG10 here.  */
4352         gfrt = FFECOM_gfrtL_LOG10;
4353       else if (kt == FFEINFO_kindtypeREAL2)
4354         /* We used to call FFECOM_gfrtDLOG10 here.  */
4355         gfrt = FFECOM_gfrtL_LOG10;
4356       break;
4357
4358     case FFEINTRIN_impMAX:
4359     case FFEINTRIN_impAMAX0:
4360     case FFEINTRIN_impAMAX1:
4361     case FFEINTRIN_impDMAX1:
4362     case FFEINTRIN_impMAX0:
4363     case FFEINTRIN_impMAX1:
4364       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4365         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4366       else
4367         arg1_type = tree_type;
4368       expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4369                             convert (arg1_type, ffecom_expr (arg1)),
4370                             convert (arg1_type, ffecom_expr (arg2)));
4371       for (; list != NULL; list = ffebld_trail (list))
4372         {
4373           if ((ffebld_head (list) == NULL)
4374               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4375             continue;
4376           expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4377                                 expr_tree,
4378                                 convert (arg1_type,
4379                                          ffecom_expr (ffebld_head (list))));
4380         }
4381       return convert (tree_type, expr_tree);
4382
4383     case FFEINTRIN_impMIN:
4384     case FFEINTRIN_impAMIN0:
4385     case FFEINTRIN_impAMIN1:
4386     case FFEINTRIN_impDMIN1:
4387     case FFEINTRIN_impMIN0:
4388     case FFEINTRIN_impMIN1:
4389       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4390         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4391       else
4392         arg1_type = tree_type;
4393       expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4394                             convert (arg1_type, ffecom_expr (arg1)),
4395                             convert (arg1_type, ffecom_expr (arg2)));
4396       for (; list != NULL; list = ffebld_trail (list))
4397         {
4398           if ((ffebld_head (list) == NULL)
4399               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4400             continue;
4401           expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4402                                 expr_tree,
4403                                 convert (arg1_type,
4404                                          ffecom_expr (ffebld_head (list))));
4405         }
4406       return convert (tree_type, expr_tree);
4407
4408     case FFEINTRIN_impMOD:
4409     case FFEINTRIN_impAMOD:
4410     case FFEINTRIN_impDMOD:
4411       if (bt != FFEINFO_basictypeREAL)
4412         return ffecom_2 (TRUNC_MOD_EXPR, tree_type,
4413                          convert (tree_type, ffecom_expr (arg1)),
4414                          convert (tree_type, ffecom_expr (arg2)));
4415
4416       if (kt == FFEINFO_kindtypeREAL1)
4417         /* We used to call FFECOM_gfrtAMOD here.  */
4418         gfrt = FFECOM_gfrtL_FMOD;
4419       else if (kt == FFEINFO_kindtypeREAL2)
4420         /* We used to call FFECOM_gfrtDMOD here.  */
4421         gfrt = FFECOM_gfrtL_FMOD;
4422       break;
4423
4424     case FFEINTRIN_impNINT:
4425     case FFEINTRIN_impIDNINT:
4426 #if 0
4427       /* ~~Ideally FIX_ROUND_EXPR would be implemented, but it ain't yet.  */
4428       return ffecom_1 (FIX_ROUND_EXPR, tree_type, ffecom_expr (arg1));
4429 #else
4430       /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
4431       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4432       return
4433         convert (ffecom_integer_type_node,
4434                  ffecom_3 (COND_EXPR, arg1_type,
4435                            ffecom_truth_value
4436                            (ffecom_2 (GE_EXPR, integer_type_node,
4437                                       saved_expr1,
4438                                       convert (arg1_type,
4439                                                ffecom_float_zero_))),
4440                            ffecom_2 (PLUS_EXPR, arg1_type,
4441                                      saved_expr1,
4442                                      convert (arg1_type,
4443                                               ffecom_float_half_)),
4444                            ffecom_2 (MINUS_EXPR, arg1_type,
4445                                      saved_expr1,
4446                                      convert (arg1_type,
4447                                               ffecom_float_half_))));
4448 #endif
4449
4450     case FFEINTRIN_impSIGN:
4451     case FFEINTRIN_impDSIGN:
4452     case FFEINTRIN_impISIGN:
4453       {
4454         tree arg2_tree = ffecom_expr (arg2);
4455
4456         saved_expr1
4457           = ffecom_save_tree
4458           (ffecom_1 (ABS_EXPR, tree_type,
4459                      convert (tree_type,
4460                               ffecom_expr (arg1))));
4461         expr_tree
4462           = ffecom_3 (COND_EXPR, tree_type,
4463                       ffecom_truth_value
4464                       (ffecom_2 (GE_EXPR, integer_type_node,
4465                                  arg2_tree,
4466                                  convert (TREE_TYPE (arg2_tree),
4467                                           integer_zero_node))),
4468                       saved_expr1,
4469                       ffecom_1 (NEGATE_EXPR, tree_type, saved_expr1));
4470         /* Make sure SAVE_EXPRs get referenced early enough. */
4471         expr_tree
4472           = ffecom_2 (COMPOUND_EXPR, tree_type,
4473                       convert (void_type_node, saved_expr1),
4474                       expr_tree);
4475       }
4476       return expr_tree;
4477
4478     case FFEINTRIN_impSIN:
4479     case FFEINTRIN_impCDSIN:
4480     case FFEINTRIN_impCSIN:
4481     case FFEINTRIN_impDSIN:
4482       if (bt == FFEINFO_basictypeCOMPLEX)
4483         {
4484           if (kt == FFEINFO_kindtypeREAL1)
4485             gfrt = FFECOM_gfrtCSIN;     /* Overlapping result okay. */
4486           else if (kt == FFEINFO_kindtypeREAL2)
4487             gfrt = FFECOM_gfrtCDSIN;    /* Overlapping result okay. */
4488         }
4489       break;
4490
4491     case FFEINTRIN_impSINH:
4492     case FFEINTRIN_impDSINH:
4493       break;
4494
4495     case FFEINTRIN_impSQRT:
4496     case FFEINTRIN_impCDSQRT:
4497     case FFEINTRIN_impCSQRT:
4498     case FFEINTRIN_impDSQRT:
4499       if (bt == FFEINFO_basictypeCOMPLEX)
4500         {
4501           if (kt == FFEINFO_kindtypeREAL1)
4502             gfrt = FFECOM_gfrtCSQRT;    /* Overlapping result okay. */
4503           else if (kt == FFEINFO_kindtypeREAL2)
4504             gfrt = FFECOM_gfrtCDSQRT;   /* Overlapping result okay. */
4505         }
4506       break;
4507
4508     case FFEINTRIN_impTAN:
4509     case FFEINTRIN_impDTAN:
4510     case FFEINTRIN_impTANH:
4511     case FFEINTRIN_impDTANH:
4512       break;
4513
4514     case FFEINTRIN_impREALPART:
4515       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
4516         arg1_type = TREE_TYPE (arg1_type);
4517       else
4518         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
4519
4520       return
4521         convert (tree_type,
4522                  ffecom_1 (REALPART_EXPR, arg1_type,
4523                            ffecom_expr (arg1)));
4524
4525     case FFEINTRIN_impIAND:
4526     case FFEINTRIN_impAND:
4527       return ffecom_2 (BIT_AND_EXPR, tree_type,
4528                        convert (tree_type,
4529                                 ffecom_expr (arg1)),
4530                        convert (tree_type,
4531                                 ffecom_expr (arg2)));
4532
4533     case FFEINTRIN_impIOR:
4534     case FFEINTRIN_impOR:
4535       return ffecom_2 (BIT_IOR_EXPR, tree_type,
4536                        convert (tree_type,
4537                                 ffecom_expr (arg1)),
4538                        convert (tree_type,
4539                                 ffecom_expr (arg2)));
4540
4541     case FFEINTRIN_impIEOR:
4542     case FFEINTRIN_impXOR:
4543       return ffecom_2 (BIT_XOR_EXPR, tree_type,
4544                        convert (tree_type,
4545                                 ffecom_expr (arg1)),
4546                        convert (tree_type,
4547                                 ffecom_expr (arg2)));
4548
4549     case FFEINTRIN_impLSHIFT:
4550       return ffecom_2 (LSHIFT_EXPR, tree_type,
4551                        ffecom_expr (arg1),
4552                        convert (integer_type_node,
4553                                 ffecom_expr (arg2)));
4554
4555     case FFEINTRIN_impRSHIFT:
4556       return ffecom_2 (RSHIFT_EXPR, tree_type,
4557                        ffecom_expr (arg1),
4558                        convert (integer_type_node,
4559                                 ffecom_expr (arg2)));
4560
4561     case FFEINTRIN_impNOT:
4562       return ffecom_1 (BIT_NOT_EXPR, tree_type, ffecom_expr (arg1));
4563
4564     case FFEINTRIN_impBIT_SIZE:
4565       return convert (tree_type, TYPE_SIZE (arg1_type));
4566
4567     case FFEINTRIN_impBTEST:
4568       {
4569         ffetargetLogical1 true;
4570         ffetargetLogical1 false;
4571         tree true_tree;
4572         tree false_tree;
4573
4574         ffetarget_logical1 (&true, TRUE);
4575         ffetarget_logical1 (&false, FALSE);
4576         if (true == 1)
4577           true_tree = convert (tree_type, integer_one_node);
4578         else
4579           true_tree = convert (tree_type, build_int_2 (true, 0));
4580         if (false == 0)
4581           false_tree = convert (tree_type, integer_zero_node);
4582         else
4583           false_tree = convert (tree_type, build_int_2 (false, 0));
4584
4585         return
4586           ffecom_3 (COND_EXPR, tree_type,
4587                     ffecom_truth_value
4588                     (ffecom_2 (EQ_EXPR, integer_type_node,
4589                                ffecom_2 (BIT_AND_EXPR, arg1_type,
4590                                          ffecom_expr (arg1),
4591                                          ffecom_2 (LSHIFT_EXPR, arg1_type,
4592                                                    convert (arg1_type,
4593                                                           integer_one_node),
4594                                                    convert (integer_type_node,
4595                                                             ffecom_expr (arg2)))),
4596                                convert (arg1_type,
4597                                         integer_zero_node))),
4598                     false_tree,
4599                     true_tree);
4600       }
4601
4602     case FFEINTRIN_impIBCLR:
4603       return
4604         ffecom_2 (BIT_AND_EXPR, tree_type,
4605                   ffecom_expr (arg1),
4606                   ffecom_1 (BIT_NOT_EXPR, tree_type,
4607                             ffecom_2 (LSHIFT_EXPR, tree_type,
4608                                       convert (tree_type,
4609                                                integer_one_node),
4610                                       convert (integer_type_node,
4611                                                ffecom_expr (arg2)))));
4612
4613     case FFEINTRIN_impIBITS:
4614       {
4615         tree arg3_tree = ffecom_save_tree (convert (integer_type_node,
4616                                                     ffecom_expr (arg3)));
4617         tree uns_type
4618         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4619
4620         expr_tree
4621           = ffecom_2 (BIT_AND_EXPR, tree_type,
4622                       ffecom_2 (RSHIFT_EXPR, tree_type,
4623                                 ffecom_expr (arg1),
4624                                 convert (integer_type_node,
4625                                          ffecom_expr (arg2))),
4626                       convert (tree_type,
4627                                ffecom_2 (RSHIFT_EXPR, uns_type,
4628                                          ffecom_1 (BIT_NOT_EXPR,
4629                                                    uns_type,
4630                                                    convert (uns_type,
4631                                                         integer_zero_node)),
4632                                          ffecom_2 (MINUS_EXPR,
4633                                                    integer_type_node,
4634                                                    TYPE_SIZE (uns_type),
4635                                                    arg3_tree))));
4636 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4637         expr_tree
4638           = ffecom_3 (COND_EXPR, tree_type,
4639                       ffecom_truth_value
4640                       (ffecom_2 (NE_EXPR, integer_type_node,
4641                                  arg3_tree,
4642                                  integer_zero_node)),
4643                       expr_tree,
4644                       convert (tree_type, integer_zero_node));
4645 #endif
4646       }
4647       return expr_tree;
4648
4649     case FFEINTRIN_impIBSET:
4650       return
4651         ffecom_2 (BIT_IOR_EXPR, tree_type,
4652                   ffecom_expr (arg1),
4653                   ffecom_2 (LSHIFT_EXPR, tree_type,
4654                             convert (tree_type, integer_one_node),
4655                             convert (integer_type_node,
4656                                      ffecom_expr (arg2))));
4657
4658     case FFEINTRIN_impISHFT:
4659       {
4660         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4661         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4662                                                     ffecom_expr (arg2)));
4663         tree uns_type
4664         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4665
4666         expr_tree
4667           = ffecom_3 (COND_EXPR, tree_type,
4668                       ffecom_truth_value
4669                       (ffecom_2 (GE_EXPR, integer_type_node,
4670                                  arg2_tree,
4671                                  integer_zero_node)),
4672                       ffecom_2 (LSHIFT_EXPR, tree_type,
4673                                 arg1_tree,
4674                                 arg2_tree),
4675                       convert (tree_type,
4676                                ffecom_2 (RSHIFT_EXPR, uns_type,
4677                                          convert (uns_type, arg1_tree),
4678                                          ffecom_1 (NEGATE_EXPR,
4679                                                    integer_type_node,
4680                                                    arg2_tree))));
4681 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4682         expr_tree
4683           = ffecom_3 (COND_EXPR, tree_type,
4684                       ffecom_truth_value
4685                       (ffecom_2 (NE_EXPR, integer_type_node,
4686                                  arg2_tree,
4687                                  TYPE_SIZE (uns_type))),
4688                       expr_tree,
4689                       convert (tree_type, integer_zero_node));
4690 #endif
4691         /* Make sure SAVE_EXPRs get referenced early enough. */
4692         expr_tree
4693           = ffecom_2 (COMPOUND_EXPR, tree_type,
4694                       convert (void_type_node, arg1_tree),
4695                       ffecom_2 (COMPOUND_EXPR, tree_type,
4696                                 convert (void_type_node, arg2_tree),
4697                                 expr_tree));
4698       }
4699       return expr_tree;
4700
4701     case FFEINTRIN_impISHFTC:
4702       {
4703         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4704         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4705                                                     ffecom_expr (arg2)));
4706         tree arg3_tree = (arg3 == NULL) ? TYPE_SIZE (tree_type)
4707         : ffecom_save_tree (convert (integer_type_node, ffecom_expr (arg3)));
4708         tree shift_neg;
4709         tree shift_pos;
4710         tree mask_arg1;
4711         tree masked_arg1;
4712         tree uns_type
4713         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4714
4715         mask_arg1
4716           = ffecom_2 (LSHIFT_EXPR, tree_type,
4717                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4718                                 convert (tree_type, integer_zero_node)),
4719                       arg3_tree);
4720 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4721         mask_arg1
4722           = ffecom_3 (COND_EXPR, tree_type,
4723                       ffecom_truth_value
4724                       (ffecom_2 (NE_EXPR, integer_type_node,
4725                                  arg3_tree,
4726                                  TYPE_SIZE (uns_type))),
4727                       mask_arg1,
4728                       convert (tree_type, integer_zero_node));
4729 #endif
4730         mask_arg1 = ffecom_save_tree (mask_arg1);
4731         masked_arg1
4732           = ffecom_2 (BIT_AND_EXPR, tree_type,
4733                       arg1_tree,
4734                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4735                                 mask_arg1));
4736         masked_arg1 = ffecom_save_tree (masked_arg1);
4737         shift_neg
4738           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4739                       convert (tree_type,
4740                                ffecom_2 (RSHIFT_EXPR, uns_type,
4741                                          convert (uns_type, masked_arg1),
4742                                          ffecom_1 (NEGATE_EXPR,
4743                                                    integer_type_node,
4744                                                    arg2_tree))),
4745                       ffecom_2 (LSHIFT_EXPR, tree_type,
4746                                 arg1_tree,
4747                                 ffecom_2 (PLUS_EXPR, integer_type_node,
4748                                           arg2_tree,
4749                                           arg3_tree)));
4750         shift_pos
4751           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4752                       ffecom_2 (LSHIFT_EXPR, tree_type,
4753                                 arg1_tree,
4754                                 arg2_tree),
4755                       convert (tree_type,
4756                                ffecom_2 (RSHIFT_EXPR, uns_type,
4757                                          convert (uns_type, masked_arg1),
4758                                          ffecom_2 (MINUS_EXPR,
4759                                                    integer_type_node,
4760                                                    arg3_tree,
4761                                                    arg2_tree))));
4762         expr_tree
4763           = ffecom_3 (COND_EXPR, tree_type,
4764                       ffecom_truth_value
4765                       (ffecom_2 (LT_EXPR, integer_type_node,
4766                                  arg2_tree,
4767                                  integer_zero_node)),
4768                       shift_neg,
4769                       shift_pos);
4770         expr_tree
4771           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4772                       ffecom_2 (BIT_AND_EXPR, tree_type,
4773                                 mask_arg1,
4774                                 arg1_tree),
4775                       ffecom_2 (BIT_AND_EXPR, tree_type,
4776                                 ffecom_1 (BIT_NOT_EXPR, tree_type,
4777                                           mask_arg1),
4778                                 expr_tree));
4779         expr_tree
4780           = ffecom_3 (COND_EXPR, tree_type,
4781                       ffecom_truth_value
4782                       (ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
4783                                  ffecom_2 (EQ_EXPR, integer_type_node,
4784                                            ffecom_1 (ABS_EXPR,
4785                                                      integer_type_node,
4786                                                      arg2_tree),
4787                                            arg3_tree),
4788                                  ffecom_2 (EQ_EXPR, integer_type_node,
4789                                            arg2_tree,
4790                                            integer_zero_node))),
4791                       arg1_tree,
4792                       expr_tree);
4793         /* Make sure SAVE_EXPRs get referenced early enough. */
4794         expr_tree
4795           = ffecom_2 (COMPOUND_EXPR, tree_type,
4796                       convert (void_type_node, arg1_tree),
4797                       ffecom_2 (COMPOUND_EXPR, tree_type,
4798                                 convert (void_type_node, arg2_tree),
4799                                 ffecom_2 (COMPOUND_EXPR, tree_type,
4800                                           convert (void_type_node,
4801                                                    mask_arg1),
4802                                           ffecom_2 (COMPOUND_EXPR, tree_type,
4803                                                     convert (void_type_node,
4804                                                              masked_arg1),
4805                                                     expr_tree))));
4806         expr_tree
4807           = ffecom_2 (COMPOUND_EXPR, tree_type,
4808                       convert (void_type_node,
4809                                arg3_tree),
4810                       expr_tree);
4811       }
4812       return expr_tree;
4813
4814     case FFEINTRIN_impLOC:
4815       {
4816         tree arg1_tree = ffecom_expr (arg1);
4817
4818         expr_tree
4819           = convert (tree_type,
4820                      ffecom_1 (ADDR_EXPR,
4821                                build_pointer_type (TREE_TYPE (arg1_tree)),
4822                                arg1_tree));
4823       }
4824       return expr_tree;
4825
4826     case FFEINTRIN_impMVBITS:
4827       {
4828         tree arg1_tree;
4829         tree arg2_tree;
4830         tree arg3_tree;
4831         ffebld arg4 = ffebld_head (ffebld_trail (list));
4832         tree arg4_tree;
4833         tree arg4_type;
4834         ffebld arg5 = ffebld_head (ffebld_trail (ffebld_trail (list)));
4835         tree arg5_tree;
4836         tree prep_arg1;
4837         tree prep_arg4;
4838         tree arg5_plus_arg3;
4839
4840         arg2_tree = convert (integer_type_node,
4841                              ffecom_expr (arg2));
4842         arg3_tree = ffecom_save_tree (convert (integer_type_node,
4843                                                ffecom_expr (arg3)));
4844         arg4_tree = ffecom_expr_rw (NULL_TREE, arg4);
4845         arg4_type = TREE_TYPE (arg4_tree);
4846
4847         arg1_tree = ffecom_save_tree (convert (arg4_type,
4848                                                ffecom_expr (arg1)));
4849
4850         arg5_tree = ffecom_save_tree (convert (integer_type_node,
4851                                                ffecom_expr (arg5)));
4852
4853         prep_arg1
4854           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4855                       ffecom_2 (BIT_AND_EXPR, arg4_type,
4856                                 ffecom_2 (RSHIFT_EXPR, arg4_type,
4857                                           arg1_tree,
4858                                           arg2_tree),
4859                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4860                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4861                                                     ffecom_1 (BIT_NOT_EXPR,
4862                                                               arg4_type,
4863                                                               convert
4864                                                               (arg4_type,
4865                                                         integer_zero_node)),
4866                                                     arg3_tree))),
4867                       arg5_tree);
4868         arg5_plus_arg3
4869           = ffecom_save_tree (ffecom_2 (PLUS_EXPR, arg4_type,
4870                                         arg5_tree,
4871                                         arg3_tree));
4872         prep_arg4
4873           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4874                       ffecom_1 (BIT_NOT_EXPR, arg4_type,
4875                                 convert (arg4_type,
4876                                          integer_zero_node)),
4877                       arg5_plus_arg3);
4878 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4879         prep_arg4
4880           = ffecom_3 (COND_EXPR, arg4_type,
4881                       ffecom_truth_value
4882                       (ffecom_2 (NE_EXPR, integer_type_node,
4883                                  arg5_plus_arg3,
4884                                  convert (TREE_TYPE (arg5_plus_arg3),
4885                                           TYPE_SIZE (arg4_type)))),
4886                       prep_arg4,
4887                       convert (arg4_type, integer_zero_node));
4888 #endif
4889         prep_arg4
4890           = ffecom_2 (BIT_AND_EXPR, arg4_type,
4891                       arg4_tree,
4892                       ffecom_2 (BIT_IOR_EXPR, arg4_type,
4893                                 prep_arg4,
4894                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4895                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4896                                                     ffecom_1 (BIT_NOT_EXPR,
4897                                                               arg4_type,
4898                                                               convert
4899                                                               (arg4_type,
4900                                                         integer_zero_node)),
4901                                                     arg5_tree))));
4902         prep_arg1
4903           = ffecom_2 (BIT_IOR_EXPR, arg4_type,
4904                       prep_arg1,
4905                       prep_arg4);
4906 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4907         prep_arg1
4908           = ffecom_3 (COND_EXPR, arg4_type,
4909                       ffecom_truth_value
4910                       (ffecom_2 (NE_EXPR, integer_type_node,
4911                                  arg3_tree,
4912                                  convert (TREE_TYPE (arg3_tree),
4913                                           integer_zero_node))),
4914                       prep_arg1,
4915                       arg4_tree);
4916         prep_arg1
4917           = ffecom_3 (COND_EXPR, arg4_type,
4918                       ffecom_truth_value
4919                       (ffecom_2 (NE_EXPR, integer_type_node,
4920                                  arg3_tree,
4921                                  convert (TREE_TYPE (arg3_tree),
4922                                           TYPE_SIZE (arg4_type)))),
4923                       prep_arg1,
4924                       arg1_tree);
4925 #endif
4926         expr_tree
4927           = ffecom_2s (MODIFY_EXPR, void_type_node,
4928                        arg4_tree,
4929                        prep_arg1);
4930         /* Make sure SAVE_EXPRs get referenced early enough. */
4931         expr_tree
4932           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4933                       arg1_tree,
4934                       ffecom_2 (COMPOUND_EXPR, void_type_node,
4935                                 arg3_tree,
4936                                 ffecom_2 (COMPOUND_EXPR, void_type_node,
4937                                           arg5_tree,
4938                                           ffecom_2 (COMPOUND_EXPR, void_type_node,
4939                                                     arg5_plus_arg3,
4940                                                     expr_tree))));
4941         expr_tree
4942           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4943                       arg4_tree,
4944                       expr_tree);
4945
4946       }
4947       return expr_tree;
4948
4949     case FFEINTRIN_impDERF:
4950     case FFEINTRIN_impERF:
4951     case FFEINTRIN_impDERFC:
4952     case FFEINTRIN_impERFC:
4953       break;
4954
4955     case FFEINTRIN_impIARGC:
4956       /* extern int xargc; i__1 = xargc - 1; */
4957       expr_tree = ffecom_2 (MINUS_EXPR, TREE_TYPE (ffecom_tree_xargc_),
4958                             ffecom_tree_xargc_,
4959                             convert (TREE_TYPE (ffecom_tree_xargc_),
4960                                      integer_one_node));
4961       return expr_tree;
4962
4963     case FFEINTRIN_impSIGNAL_func:
4964     case FFEINTRIN_impSIGNAL_subr:
4965       {
4966         tree arg1_tree;
4967         tree arg2_tree;
4968         tree arg3_tree;
4969
4970         arg1_tree = convert (ffecom_f2c_integer_type_node,
4971                              ffecom_expr (arg1));
4972         arg1_tree = ffecom_1 (ADDR_EXPR,
4973                               build_pointer_type (TREE_TYPE (arg1_tree)),
4974                               arg1_tree);
4975
4976         /* Pass procedure as a pointer to it, anything else by value.  */
4977         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4978           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4979         else
4980           arg2_tree = ffecom_ptr_to_expr (arg2);
4981         arg2_tree = convert (TREE_TYPE (null_pointer_node),
4982                              arg2_tree);
4983
4984         if (arg3 != NULL)
4985           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4986         else
4987           arg3_tree = NULL_TREE;
4988
4989         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4990         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4991         TREE_CHAIN (arg1_tree) = arg2_tree;
4992
4993         expr_tree
4994           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4995                           ffecom_gfrt_kindtype (gfrt),
4996                           FALSE,
4997                           ((codegen_imp == FFEINTRIN_impSIGNAL_subr) ?
4998                            NULL_TREE :
4999                            tree_type),
5000                           arg1_tree,
5001                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5002                           ffebld_nonter_hook (expr));
5003
5004         if (arg3_tree != NULL_TREE)
5005           expr_tree
5006             = ffecom_modify (NULL_TREE, arg3_tree,
5007                              convert (TREE_TYPE (arg3_tree),
5008                                       expr_tree));
5009       }
5010       return expr_tree;
5011
5012     case FFEINTRIN_impALARM:
5013       {
5014         tree arg1_tree;
5015         tree arg2_tree;
5016         tree arg3_tree;
5017
5018         arg1_tree = convert (ffecom_f2c_integer_type_node,
5019                              ffecom_expr (arg1));
5020         arg1_tree = ffecom_1 (ADDR_EXPR,
5021                               build_pointer_type (TREE_TYPE (arg1_tree)),
5022                               arg1_tree);
5023
5024         /* Pass procedure as a pointer to it, anything else by value.  */
5025         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
5026           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
5027         else
5028           arg2_tree = ffecom_ptr_to_expr (arg2);
5029         arg2_tree = convert (TREE_TYPE (null_pointer_node),
5030                              arg2_tree);
5031
5032         if (arg3 != NULL)
5033           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5034         else
5035           arg3_tree = NULL_TREE;
5036
5037         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5038         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5039         TREE_CHAIN (arg1_tree) = arg2_tree;
5040
5041         expr_tree
5042           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5043                           ffecom_gfrt_kindtype (gfrt),
5044                           FALSE,
5045                           NULL_TREE,
5046                           arg1_tree,
5047                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5048                           ffebld_nonter_hook (expr));
5049
5050         if (arg3_tree != NULL_TREE)
5051           expr_tree
5052             = ffecom_modify (NULL_TREE, arg3_tree,
5053                              convert (TREE_TYPE (arg3_tree),
5054                                       expr_tree));
5055       }
5056       return expr_tree;
5057
5058     case FFEINTRIN_impCHDIR_subr:
5059     case FFEINTRIN_impFDATE_subr:
5060     case FFEINTRIN_impFGET_subr:
5061     case FFEINTRIN_impFPUT_subr:
5062     case FFEINTRIN_impGETCWD_subr:
5063     case FFEINTRIN_impHOSTNM_subr:
5064     case FFEINTRIN_impSYSTEM_subr:
5065     case FFEINTRIN_impUNLINK_subr:
5066       {
5067         tree arg1_len = integer_zero_node;
5068         tree arg1_tree;
5069         tree arg2_tree;
5070
5071         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5072
5073         if (arg2 != NULL)
5074           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
5075         else
5076           arg2_tree = NULL_TREE;
5077
5078         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5079         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5080         TREE_CHAIN (arg1_tree) = arg1_len;
5081
5082         expr_tree
5083           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5084                           ffecom_gfrt_kindtype (gfrt),
5085                           FALSE,
5086                           NULL_TREE,
5087                           arg1_tree,
5088                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5089                           ffebld_nonter_hook (expr));
5090
5091         if (arg2_tree != NULL_TREE)
5092           expr_tree
5093             = ffecom_modify (NULL_TREE, arg2_tree,
5094                              convert (TREE_TYPE (arg2_tree),
5095                                       expr_tree));
5096       }
5097       return expr_tree;
5098
5099     case FFEINTRIN_impEXIT:
5100       if (arg1 != NULL)
5101         break;
5102
5103       expr_tree = build_tree_list (NULL_TREE,
5104                                    ffecom_1 (ADDR_EXPR,
5105                                              build_pointer_type
5106                                              (ffecom_integer_type_node),
5107                                              integer_zero_node));
5108
5109       return
5110         ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5111                       ffecom_gfrt_kindtype (gfrt),
5112                       FALSE,
5113                       void_type_node,
5114                       expr_tree,
5115                       NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5116                       ffebld_nonter_hook (expr));
5117
5118     case FFEINTRIN_impFLUSH:
5119       if (arg1 == NULL)
5120         gfrt = FFECOM_gfrtFLUSH;
5121       else
5122         gfrt = FFECOM_gfrtFLUSH1;
5123       break;
5124
5125     case FFEINTRIN_impCHMOD_subr:
5126     case FFEINTRIN_impLINK_subr:
5127     case FFEINTRIN_impRENAME_subr:
5128     case FFEINTRIN_impSYMLNK_subr:
5129       {
5130         tree arg1_len = integer_zero_node;
5131         tree arg1_tree;
5132         tree arg2_len = integer_zero_node;
5133         tree arg2_tree;
5134         tree arg3_tree;
5135
5136         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5137         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
5138         if (arg3 != NULL)
5139           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5140         else
5141           arg3_tree = NULL_TREE;
5142
5143         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5144         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5145         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5146         arg2_len = build_tree_list (NULL_TREE, arg2_len);
5147         TREE_CHAIN (arg1_tree) = arg2_tree;
5148         TREE_CHAIN (arg2_tree) = arg1_len;
5149         TREE_CHAIN (arg1_len) = arg2_len;
5150         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5151                                   ffecom_gfrt_kindtype (gfrt),
5152                                   FALSE,
5153                                   NULL_TREE,
5154                                   arg1_tree,
5155                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5156                                   ffebld_nonter_hook (expr));
5157         if (arg3_tree != NULL_TREE)
5158           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5159                                      convert (TREE_TYPE (arg3_tree),
5160                                               expr_tree));
5161       }
5162       return expr_tree;
5163
5164     case FFEINTRIN_impLSTAT_subr:
5165     case FFEINTRIN_impSTAT_subr:
5166       {
5167         tree arg1_len = integer_zero_node;
5168         tree arg1_tree;
5169         tree arg2_tree;
5170         tree arg3_tree;
5171
5172         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5173
5174         arg2_tree = ffecom_ptr_to_expr (arg2);
5175
5176         if (arg3 != NULL)
5177           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5178         else
5179           arg3_tree = NULL_TREE;
5180
5181         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5182         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5183         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5184         TREE_CHAIN (arg1_tree) = arg2_tree;
5185         TREE_CHAIN (arg2_tree) = arg1_len;
5186         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5187                                   ffecom_gfrt_kindtype (gfrt),
5188                                   FALSE,
5189                                   NULL_TREE,
5190                                   arg1_tree,
5191                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5192                                   ffebld_nonter_hook (expr));
5193         if (arg3_tree != NULL_TREE)
5194           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5195                                      convert (TREE_TYPE (arg3_tree),
5196                                               expr_tree));
5197       }
5198       return expr_tree;
5199
5200     case FFEINTRIN_impFGETC_subr:
5201     case FFEINTRIN_impFPUTC_subr:
5202       {
5203         tree arg1_tree;
5204         tree arg2_tree;
5205         tree arg2_len = integer_zero_node;
5206         tree arg3_tree;
5207
5208         arg1_tree = convert (ffecom_f2c_integer_type_node,
5209                              ffecom_expr (arg1));
5210         arg1_tree = ffecom_1 (ADDR_EXPR,
5211                               build_pointer_type (TREE_TYPE (arg1_tree)),
5212                               arg1_tree);
5213
5214         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
5215         if (arg3 != NULL)
5216           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5217         else
5218           arg3_tree = NULL_TREE;
5219
5220         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5221         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5222         arg2_len = build_tree_list (NULL_TREE, arg2_len);
5223         TREE_CHAIN (arg1_tree) = arg2_tree;
5224         TREE_CHAIN (arg2_tree) = arg2_len;
5225
5226         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5227                                   ffecom_gfrt_kindtype (gfrt),
5228                                   FALSE,
5229                                   NULL_TREE,
5230                                   arg1_tree,
5231                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5232                                   ffebld_nonter_hook (expr));
5233         if (arg3_tree != NULL_TREE)
5234           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5235                                      convert (TREE_TYPE (arg3_tree),
5236                                               expr_tree));
5237       }
5238       return expr_tree;
5239
5240     case FFEINTRIN_impFSTAT_subr:
5241       {
5242         tree arg1_tree;
5243         tree arg2_tree;
5244         tree arg3_tree;
5245
5246         arg1_tree = convert (ffecom_f2c_integer_type_node,
5247                              ffecom_expr (arg1));
5248         arg1_tree = ffecom_1 (ADDR_EXPR,
5249                               build_pointer_type (TREE_TYPE (arg1_tree)),
5250                               arg1_tree);
5251
5252         arg2_tree = convert (ffecom_f2c_ptr_to_integer_type_node,
5253                              ffecom_ptr_to_expr (arg2));
5254
5255         if (arg3 == NULL)
5256           arg3_tree = NULL_TREE;
5257         else
5258           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5259
5260         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5261         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5262         TREE_CHAIN (arg1_tree) = arg2_tree;
5263         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5264                                   ffecom_gfrt_kindtype (gfrt),
5265                                   FALSE,
5266                                   NULL_TREE,
5267                                   arg1_tree,
5268                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5269                                   ffebld_nonter_hook (expr));
5270         if (arg3_tree != NULL_TREE) {
5271           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5272                                      convert (TREE_TYPE (arg3_tree),
5273                                               expr_tree));
5274         }
5275       }
5276       return expr_tree;
5277
5278     case FFEINTRIN_impKILL_subr:
5279       {
5280         tree arg1_tree;
5281         tree arg2_tree;
5282         tree arg3_tree;
5283
5284         arg1_tree = convert (ffecom_f2c_integer_type_node,
5285                              ffecom_expr (arg1));
5286         arg1_tree = ffecom_1 (ADDR_EXPR,
5287                               build_pointer_type (TREE_TYPE (arg1_tree)),
5288                               arg1_tree);
5289
5290         arg2_tree = convert (ffecom_f2c_integer_type_node,
5291                              ffecom_expr (arg2));
5292         arg2_tree = ffecom_1 (ADDR_EXPR,
5293                               build_pointer_type (TREE_TYPE (arg2_tree)),
5294                               arg2_tree);
5295
5296         if (arg3 == NULL)
5297           arg3_tree = NULL_TREE;
5298         else
5299           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5300
5301         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5302         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5303         TREE_CHAIN (arg1_tree) = arg2_tree;
5304         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5305                                   ffecom_gfrt_kindtype (gfrt),
5306                                   FALSE,
5307                                   NULL_TREE,
5308                                   arg1_tree,
5309                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5310                                   ffebld_nonter_hook (expr));
5311         if (arg3_tree != NULL_TREE) {
5312           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5313                                      convert (TREE_TYPE (arg3_tree),
5314                                               expr_tree));
5315         }
5316       }
5317       return expr_tree;
5318
5319     case FFEINTRIN_impCTIME_subr:
5320     case FFEINTRIN_impTTYNAM_subr:
5321       {
5322         tree arg1_len = integer_zero_node;
5323         tree arg1_tree;
5324         tree arg2_tree;
5325
5326         arg1_tree = ffecom_arg_ptr_to_expr (arg2, &arg1_len);
5327
5328         arg2_tree = convert (((codegen_imp == FFEINTRIN_impCTIME_subr) ?
5329                               ffecom_f2c_longint_type_node :
5330                               ffecom_f2c_integer_type_node),
5331                              ffecom_expr (arg1));
5332         arg2_tree = ffecom_1 (ADDR_EXPR,
5333                               build_pointer_type (TREE_TYPE (arg2_tree)),
5334                               arg2_tree);
5335
5336         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5337         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5338         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5339         TREE_CHAIN (arg1_len) = arg2_tree;
5340         TREE_CHAIN (arg1_tree) = arg1_len;
5341
5342         expr_tree
5343           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5344                           ffecom_gfrt_kindtype (gfrt),
5345                           FALSE,
5346                           NULL_TREE,
5347                           arg1_tree,
5348                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5349                           ffebld_nonter_hook (expr));
5350         TREE_SIDE_EFFECTS (expr_tree) = 1;
5351       }
5352       return expr_tree;
5353
5354     case FFEINTRIN_impIRAND:
5355     case FFEINTRIN_impRAND:
5356       /* Arg defaults to 0 (normal random case) */
5357       {
5358         tree arg1_tree;
5359
5360         if (arg1 == NULL)
5361           arg1_tree = ffecom_integer_zero_node;
5362         else
5363           arg1_tree = ffecom_expr (arg1);
5364         arg1_tree = convert (ffecom_f2c_integer_type_node,
5365                              arg1_tree);
5366         arg1_tree = ffecom_1 (ADDR_EXPR,
5367                               build_pointer_type (TREE_TYPE (arg1_tree)),
5368                               arg1_tree);
5369         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5370
5371         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5372                                   ffecom_gfrt_kindtype (gfrt),
5373                                   FALSE,
5374                                   ((codegen_imp == FFEINTRIN_impIRAND) ?
5375                                    ffecom_f2c_integer_type_node :
5376                                    ffecom_f2c_real_type_node),
5377                                   arg1_tree,
5378                                   dest_tree, dest, dest_used,
5379                                   NULL_TREE, TRUE,
5380                                   ffebld_nonter_hook (expr));
5381       }
5382       return expr_tree;
5383
5384     case FFEINTRIN_impFTELL_subr:
5385     case FFEINTRIN_impUMASK_subr:
5386       {
5387         tree arg1_tree;
5388         tree arg2_tree;
5389
5390         arg1_tree = convert (ffecom_f2c_integer_type_node,
5391                              ffecom_expr (arg1));
5392         arg1_tree = ffecom_1 (ADDR_EXPR,
5393                               build_pointer_type (TREE_TYPE (arg1_tree)),
5394                               arg1_tree);
5395
5396         if (arg2 == NULL)
5397           arg2_tree = NULL_TREE;
5398         else
5399           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
5400
5401         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5402                                   ffecom_gfrt_kindtype (gfrt),
5403                                   FALSE,
5404                                   NULL_TREE,
5405                                   build_tree_list (NULL_TREE, arg1_tree),
5406                                   NULL_TREE, NULL, NULL, NULL_TREE,
5407                                   TRUE,
5408                                   ffebld_nonter_hook (expr));
5409         if (arg2_tree != NULL_TREE) {
5410           expr_tree = ffecom_modify (NULL_TREE, arg2_tree,
5411                                      convert (TREE_TYPE (arg2_tree),
5412                                               expr_tree));
5413         }
5414       }
5415       return expr_tree;
5416
5417     case FFEINTRIN_impCPU_TIME:
5418     case FFEINTRIN_impSECOND_subr:
5419       {
5420         tree arg1_tree;
5421
5422         arg1_tree = ffecom_expr_w (NULL_TREE, arg1);
5423
5424         expr_tree
5425           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5426                           ffecom_gfrt_kindtype (gfrt),
5427                           FALSE,
5428                           NULL_TREE,
5429                           NULL_TREE,
5430                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5431                           ffebld_nonter_hook (expr));
5432
5433         expr_tree
5434           = ffecom_modify (NULL_TREE, arg1_tree,
5435                            convert (TREE_TYPE (arg1_tree),
5436                                     expr_tree));
5437       }
5438       return expr_tree;
5439
5440     case FFEINTRIN_impDTIME_subr:
5441     case FFEINTRIN_impETIME_subr:
5442       {
5443         tree arg1_tree;
5444         tree result_tree;
5445
5446         result_tree = ffecom_expr_w (NULL_TREE, arg2);
5447
5448         arg1_tree = ffecom_ptr_to_expr (arg1);
5449
5450         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5451                                   ffecom_gfrt_kindtype (gfrt),
5452                                   FALSE,
5453                                   NULL_TREE,
5454                                   build_tree_list (NULL_TREE, arg1_tree),
5455                                   NULL_TREE, NULL, NULL, NULL_TREE,
5456                                   TRUE,
5457                                   ffebld_nonter_hook (expr));
5458         expr_tree = ffecom_modify (NULL_TREE, result_tree,
5459                                    convert (TREE_TYPE (result_tree),
5460                                             expr_tree));
5461       }
5462       return expr_tree;
5463
5464       /* Straightforward calls of libf2c routines: */
5465     case FFEINTRIN_impABORT:
5466     case FFEINTRIN_impACCESS:
5467     case FFEINTRIN_impBESJ0:
5468     case FFEINTRIN_impBESJ1:
5469     case FFEINTRIN_impBESJN:
5470     case FFEINTRIN_impBESY0:
5471     case FFEINTRIN_impBESY1:
5472     case FFEINTRIN_impBESYN:
5473     case FFEINTRIN_impCHDIR_func:
5474     case FFEINTRIN_impCHMOD_func:
5475     case FFEINTRIN_impDATE:
5476     case FFEINTRIN_impDATE_AND_TIME:
5477     case FFEINTRIN_impDBESJ0:
5478     case FFEINTRIN_impDBESJ1:
5479     case FFEINTRIN_impDBESJN:
5480     case FFEINTRIN_impDBESY0:
5481     case FFEINTRIN_impDBESY1:
5482     case FFEINTRIN_impDBESYN:
5483     case FFEINTRIN_impDTIME_func:
5484     case FFEINTRIN_impETIME_func:
5485     case FFEINTRIN_impFGETC_func:
5486     case FFEINTRIN_impFGET_func:
5487     case FFEINTRIN_impFNUM:
5488     case FFEINTRIN_impFPUTC_func:
5489     case FFEINTRIN_impFPUT_func:
5490     case FFEINTRIN_impFSEEK:
5491     case FFEINTRIN_impFSTAT_func:
5492     case FFEINTRIN_impFTELL_func:
5493     case FFEINTRIN_impGERROR:
5494     case FFEINTRIN_impGETARG:
5495     case FFEINTRIN_impGETCWD_func:
5496     case FFEINTRIN_impGETENV:
5497     case FFEINTRIN_impGETGID:
5498     case FFEINTRIN_impGETLOG:
5499     case FFEINTRIN_impGETPID:
5500     case FFEINTRIN_impGETUID:
5501     case FFEINTRIN_impGMTIME:
5502     case FFEINTRIN_impHOSTNM_func:
5503     case FFEINTRIN_impIDATE_unix:
5504     case FFEINTRIN_impIDATE_vxt:
5505     case FFEINTRIN_impIERRNO:
5506     case FFEINTRIN_impISATTY:
5507     case FFEINTRIN_impITIME:
5508     case FFEINTRIN_impKILL_func:
5509     case FFEINTRIN_impLINK_func:
5510     case FFEINTRIN_impLNBLNK:
5511     case FFEINTRIN_impLSTAT_func:
5512     case FFEINTRIN_impLTIME:
5513     case FFEINTRIN_impMCLOCK8:
5514     case FFEINTRIN_impMCLOCK:
5515     case FFEINTRIN_impPERROR:
5516     case FFEINTRIN_impRENAME_func:
5517     case FFEINTRIN_impSECNDS:
5518     case FFEINTRIN_impSECOND_func:
5519     case FFEINTRIN_impSLEEP:
5520     case FFEINTRIN_impSRAND:
5521     case FFEINTRIN_impSTAT_func:
5522     case FFEINTRIN_impSYMLNK_func:
5523     case FFEINTRIN_impSYSTEM_CLOCK:
5524     case FFEINTRIN_impSYSTEM_func:
5525     case FFEINTRIN_impTIME8:
5526     case FFEINTRIN_impTIME_unix:
5527     case FFEINTRIN_impTIME_vxt:
5528     case FFEINTRIN_impUMASK_func:
5529     case FFEINTRIN_impUNLINK_func:
5530       break;
5531
5532     case FFEINTRIN_impCTIME_func:       /* CHARACTER functions not handled here. */
5533     case FFEINTRIN_impFDATE_func:       /* CHARACTER functions not handled here. */
5534     case FFEINTRIN_impTTYNAM_func:      /* CHARACTER functions not handled here. */
5535     case FFEINTRIN_impNONE:
5536     case FFEINTRIN_imp:         /* Hush up gcc warning. */
5537       fprintf (stderr, "No %s implementation.\n",
5538                ffeintrin_name_implementation (ffebld_symter_implementation (ffebld_left (expr))));
5539       assert ("unimplemented intrinsic" == NULL);
5540       return error_mark_node;
5541     }
5542
5543   assert (gfrt != FFECOM_gfrt); /* Must have an implementation! */
5544
5545   expr_tree = ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt),
5546                                     ffebld_right (expr));
5547
5548   return ffecom_call_ (ffecom_gfrt_tree_ (gfrt), ffecom_gfrt_kindtype (gfrt),
5549                        (ffe_is_f2c_library () && ffecom_gfrt_complex_[gfrt]),
5550                        tree_type,
5551                        expr_tree, dest_tree, dest, dest_used,
5552                        NULL_TREE, TRUE,
5553                        ffebld_nonter_hook (expr));
5554
5555   /* See bottom of this file for f2c transforms used to determine
5556      many of the above implementations.  The info seems to confuse
5557      Emacs's C mode indentation, which is why it's been moved to
5558      the bottom of this source file.  */
5559 }
5560
5561 #endif
5562 /* For power (exponentiation) where right-hand operand is type INTEGER,
5563    generate in-line code to do it the fast way (which, if the operand
5564    is a constant, might just mean a series of multiplies).  */
5565
5566 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5567 static tree
5568 ffecom_expr_power_integer_ (ffebld expr)
5569 {
5570   tree l = ffecom_expr (ffebld_left (expr));
5571   tree r = ffecom_expr (ffebld_right (expr));
5572   tree ltype = TREE_TYPE (l);
5573   tree rtype = TREE_TYPE (r);
5574   tree result = NULL_TREE;
5575
5576   if (l == error_mark_node
5577       || r == error_mark_node)
5578     return error_mark_node;
5579
5580   if (TREE_CODE (r) == INTEGER_CST)
5581     {
5582       int sgn = tree_int_cst_sgn (r);
5583
5584       if (sgn == 0)
5585         return convert (ltype, integer_one_node);
5586
5587       if ((TREE_CODE (ltype) == INTEGER_TYPE)
5588           && (sgn < 0))
5589         {
5590           /* Reciprocal of integer is either 0, -1, or 1, so after
5591              calculating that (which we leave to the back end to do
5592              or not do optimally), don't bother with any multiplying.  */
5593
5594           result = ffecom_tree_divide_ (ltype,
5595                                         convert (ltype, integer_one_node),
5596                                         l,
5597                                         NULL_TREE, NULL, NULL, NULL_TREE);
5598           r = ffecom_1 (NEGATE_EXPR,
5599                         rtype,
5600                         r);
5601           if ((TREE_INT_CST_LOW (r) & 1) == 0)
5602             result = ffecom_1 (ABS_EXPR, rtype,
5603                                result);
5604         }
5605
5606       /* Generate appropriate series of multiplies, preceded
5607          by divide if the exponent is negative.  */
5608
5609       l = save_expr (l);
5610
5611       if (sgn < 0)
5612         {
5613           l = ffecom_tree_divide_ (ltype,
5614                                    convert (ltype, integer_one_node),
5615                                    l,
5616                                    NULL_TREE, NULL, NULL,
5617                                    ffebld_nonter_hook (expr));
5618           r = ffecom_1 (NEGATE_EXPR, rtype, r);
5619           assert (TREE_CODE (r) == INTEGER_CST);
5620
5621           if (tree_int_cst_sgn (r) < 0)
5622             {                   /* The "most negative" number.  */
5623               r = ffecom_1 (NEGATE_EXPR, rtype,
5624                             ffecom_2 (RSHIFT_EXPR, rtype,
5625                                       r,
5626                                       integer_one_node));
5627               l = save_expr (l);
5628               l = ffecom_2 (MULT_EXPR, ltype,
5629                             l,
5630                             l);
5631             }
5632         }
5633
5634       for (;;)
5635         {
5636           if (TREE_INT_CST_LOW (r) & 1)
5637             {
5638               if (result == NULL_TREE)
5639                 result = l;
5640               else
5641                 result = ffecom_2 (MULT_EXPR, ltype,
5642                                    result,
5643                                    l);
5644             }
5645
5646           r = ffecom_2 (RSHIFT_EXPR, rtype,
5647                         r,
5648                         integer_one_node);
5649           if (integer_zerop (r))
5650             break;
5651           assert (TREE_CODE (r) == INTEGER_CST);
5652
5653           l = save_expr (l);
5654           l = ffecom_2 (MULT_EXPR, ltype,
5655                         l,
5656                         l);
5657         }
5658       return result;
5659     }
5660
5661   /* Though rhs isn't a constant, in-line code cannot be expanded
5662      while transforming dummies
5663      because the back end cannot be easily convinced to generate
5664      stores (MODIFY_EXPR), handle temporaries, and so on before
5665      all the appropriate rtx's have been generated for things like
5666      dummy args referenced in rhs -- which doesn't happen until
5667      store_parm_decls() is called (expand_function_start, I believe,
5668      does the actual rtx-stuffing of PARM_DECLs).
5669
5670      So, in this case, let the caller generate the call to the
5671      run-time-library function to evaluate the power for us.  */
5672
5673   if (ffecom_transform_only_dummies_)
5674     return NULL_TREE;
5675
5676   /* Right-hand operand not a constant, expand in-line code to figure
5677      out how to do the multiplies, &c.
5678
5679      The returned expression is expressed this way in GNU C, where l and
5680      r are the "inputs":
5681
5682      ({ typeof (r) rtmp = r;
5683         typeof (l) ltmp = l;
5684         typeof (l) result;
5685
5686         if (rtmp == 0)
5687           result = 1;
5688         else
5689           {
5690             if ((basetypeof (l) == basetypeof (int))
5691                 && (rtmp < 0))
5692               {
5693                 result = ((typeof (l)) 1) / ltmp;
5694                 if ((ltmp < 0) && (((-rtmp) & 1) == 0))
5695                   result = -result;
5696               }
5697             else
5698               {
5699                 result = 1;
5700                 if ((basetypeof (l) != basetypeof (int))
5701                     && (rtmp < 0))
5702                   {
5703                     ltmp = ((typeof (l)) 1) / ltmp;
5704                     rtmp = -rtmp;
5705                     if (rtmp < 0)
5706                       {
5707                         rtmp = -(rtmp >> 1);
5708                         ltmp *= ltmp;
5709                       }
5710                   }
5711                 for (;;)
5712                   {
5713                     if (rtmp & 1)
5714                       result *= ltmp;
5715                     if ((rtmp >>= 1) == 0)
5716                       break;
5717                     ltmp *= ltmp;
5718                   }
5719               }
5720           }
5721         result;
5722      })
5723
5724      Note that some of the above is compile-time collapsable, such as
5725      the first part of the if statements that checks the base type of
5726      l against int.  The if statements are phrased that way to suggest
5727      an easy way to generate the if/else constructs here, knowing that
5728      the back end should (and probably does) eliminate the resulting
5729      dead code (either the int case or the non-int case), something
5730      it couldn't do without the redundant phrasing, requiring explicit
5731      dead-code elimination here, which would be kind of difficult to
5732      read.  */
5733
5734   {
5735     tree rtmp;
5736     tree ltmp;
5737     tree divide;
5738     tree basetypeof_l_is_int;
5739     tree se;
5740     tree t;
5741
5742     basetypeof_l_is_int
5743       = build_int_2 ((TREE_CODE (ltype) == INTEGER_TYPE), 0);
5744
5745     se = expand_start_stmt_expr ();
5746
5747     ffecom_start_compstmt ();
5748
5749 #ifndef HAHA
5750     rtmp = ffecom_make_tempvar ("power_r", rtype,
5751                                 FFETARGET_charactersizeNONE, -1);
5752     ltmp = ffecom_make_tempvar ("power_l", ltype,
5753                                 FFETARGET_charactersizeNONE, -1);
5754     result = ffecom_make_tempvar ("power_res", ltype,
5755                                   FFETARGET_charactersizeNONE, -1);
5756     if (TREE_CODE (ltype) == COMPLEX_TYPE
5757         || TREE_CODE (ltype) == RECORD_TYPE)
5758       divide = ffecom_make_tempvar ("power_div", ltype,
5759                                     FFETARGET_charactersizeNONE, -1);
5760     else
5761       divide = NULL_TREE;
5762 #else  /* HAHA */
5763     {
5764       tree hook;
5765
5766       hook = ffebld_nonter_hook (expr);
5767       assert (hook);
5768       assert (TREE_CODE (hook) == TREE_VEC);
5769       assert (TREE_VEC_LENGTH (hook) == 4);
5770       rtmp = TREE_VEC_ELT (hook, 0);
5771       ltmp = TREE_VEC_ELT (hook, 1);
5772       result = TREE_VEC_ELT (hook, 2);
5773       divide = TREE_VEC_ELT (hook, 3);
5774       if (TREE_CODE (ltype) == COMPLEX_TYPE
5775           || TREE_CODE (ltype) == RECORD_TYPE)
5776         assert (divide);
5777       else
5778         assert (! divide);
5779     }
5780 #endif  /* HAHA */
5781
5782     expand_expr_stmt (ffecom_modify (void_type_node,
5783                                      rtmp,
5784                                      r));
5785     expand_expr_stmt (ffecom_modify (void_type_node,
5786                                      ltmp,
5787                                      l));
5788     expand_start_cond (ffecom_truth_value
5789                        (ffecom_2 (EQ_EXPR, integer_type_node,
5790                                   rtmp,
5791                                   convert (rtype, integer_zero_node))),
5792                        0);
5793     expand_expr_stmt (ffecom_modify (void_type_node,
5794                                      result,
5795                                      convert (ltype, integer_one_node)));
5796     expand_start_else ();
5797     if (! integer_zerop (basetypeof_l_is_int))
5798       {
5799         expand_start_cond (ffecom_2 (LT_EXPR, integer_type_node,
5800                                      rtmp,
5801                                      convert (rtype,
5802                                               integer_zero_node)),
5803                            0);
5804         expand_expr_stmt (ffecom_modify (void_type_node,
5805                                          result,
5806                                          ffecom_tree_divide_
5807                                          (ltype,
5808                                           convert (ltype, integer_one_node),
5809                                           ltmp,
5810                                           NULL_TREE, NULL, NULL,
5811                                           divide)));
5812         expand_start_cond (ffecom_truth_value
5813                            (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5814                                       ffecom_2 (LT_EXPR, integer_type_node,
5815                                                 ltmp,
5816                                                 convert (ltype,
5817                                                          integer_zero_node)),
5818                                       ffecom_2 (EQ_EXPR, integer_type_node,
5819                                                 ffecom_2 (BIT_AND_EXPR,
5820                                                           rtype,
5821                                                           ffecom_1 (NEGATE_EXPR,
5822                                                                     rtype,
5823                                                                     rtmp),
5824                                                           convert (rtype,
5825                                                                    integer_one_node)),
5826                                                 convert (rtype,
5827                                                          integer_zero_node)))),
5828                            0);
5829         expand_expr_stmt (ffecom_modify (void_type_node,
5830                                          result,
5831                                          ffecom_1 (NEGATE_EXPR,
5832                                                    ltype,
5833                                                    result)));
5834         expand_end_cond ();
5835         expand_start_else ();
5836       }
5837     expand_expr_stmt (ffecom_modify (void_type_node,
5838                                      result,
5839                                      convert (ltype, integer_one_node)));
5840     expand_start_cond (ffecom_truth_value
5841                        (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5842                                   ffecom_truth_value_invert
5843                                   (basetypeof_l_is_int),
5844                                   ffecom_2 (LT_EXPR, integer_type_node,
5845                                             rtmp,
5846                                             convert (rtype,
5847                                                      integer_zero_node)))),
5848                        0);
5849     expand_expr_stmt (ffecom_modify (void_type_node,
5850                                      ltmp,
5851                                      ffecom_tree_divide_
5852                                      (ltype,
5853                                       convert (ltype, integer_one_node),
5854                                       ltmp,
5855                                       NULL_TREE, NULL, NULL,
5856                                       divide)));
5857     expand_expr_stmt (ffecom_modify (void_type_node,
5858                                      rtmp,
5859                                      ffecom_1 (NEGATE_EXPR, rtype,
5860                                                rtmp)));
5861     expand_start_cond (ffecom_truth_value
5862                        (ffecom_2 (LT_EXPR, integer_type_node,
5863                                   rtmp,
5864                                   convert (rtype, integer_zero_node))),
5865                        0);
5866     expand_expr_stmt (ffecom_modify (void_type_node,
5867                                      rtmp,
5868                                      ffecom_1 (NEGATE_EXPR, rtype,
5869                                                ffecom_2 (RSHIFT_EXPR,
5870                                                          rtype,
5871                                                          rtmp,
5872                                                          integer_one_node))));
5873     expand_expr_stmt (ffecom_modify (void_type_node,
5874                                      ltmp,
5875                                      ffecom_2 (MULT_EXPR, ltype,
5876                                                ltmp,
5877                                                ltmp)));
5878     expand_end_cond ();
5879     expand_end_cond ();
5880     expand_start_loop (1);
5881     expand_start_cond (ffecom_truth_value
5882                        (ffecom_2 (BIT_AND_EXPR, rtype,
5883                                   rtmp,
5884                                   convert (rtype, integer_one_node))),
5885                        0);
5886     expand_expr_stmt (ffecom_modify (void_type_node,
5887                                      result,
5888                                      ffecom_2 (MULT_EXPR, ltype,
5889                                                result,
5890                                                ltmp)));
5891     expand_end_cond ();
5892     expand_exit_loop_if_false (NULL,
5893                                ffecom_truth_value
5894                                (ffecom_modify (rtype,
5895                                                rtmp,
5896                                                ffecom_2 (RSHIFT_EXPR,
5897                                                          rtype,
5898                                                          rtmp,
5899                                                          integer_one_node))));
5900     expand_expr_stmt (ffecom_modify (void_type_node,
5901                                      ltmp,
5902                                      ffecom_2 (MULT_EXPR, ltype,
5903                                                ltmp,
5904                                                ltmp)));
5905     expand_end_loop ();
5906     expand_end_cond ();
5907     if (!integer_zerop (basetypeof_l_is_int))
5908       expand_end_cond ();
5909     expand_expr_stmt (result);
5910
5911     t = ffecom_end_compstmt ();
5912
5913     result = expand_end_stmt_expr (se);
5914
5915     /* This code comes from c-parse.in, after its expand_end_stmt_expr.  */
5916
5917     if (TREE_CODE (t) == BLOCK)
5918       {
5919         /* Make a BIND_EXPR for the BLOCK already made.  */
5920         result = build (BIND_EXPR, TREE_TYPE (result),
5921                         NULL_TREE, result, t);
5922         /* Remove the block from the tree at this point.
5923            It gets put back at the proper place
5924            when the BIND_EXPR is expanded.  */
5925         delete_block (t);
5926       }
5927     else
5928       result = t;
5929   }
5930
5931   return result;
5932 }
5933
5934 #endif
5935 /* ffecom_expr_transform_ -- Transform symbols in expr
5936
5937    ffebld expr;  // FFE expression.
5938    ffecom_expr_transform_ (expr);
5939
5940    Recursive descent on expr while transforming any untransformed SYMTERs.  */
5941
5942 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5943 static void
5944 ffecom_expr_transform_ (ffebld expr)
5945 {
5946   tree t;
5947   ffesymbol s;
5948
5949 tail_recurse:                   /* :::::::::::::::::::: */
5950
5951   if (expr == NULL)
5952     return;
5953
5954   switch (ffebld_op (expr))
5955     {
5956     case FFEBLD_opSYMTER:
5957       s = ffebld_symter (expr);
5958       t = ffesymbol_hook (s).decl_tree;
5959       if ((t == NULL_TREE)
5960           && ((ffesymbol_kind (s) != FFEINFO_kindNONE)
5961               || ((ffesymbol_where (s) != FFEINFO_whereNONE)
5962                   && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC))))
5963         {
5964           s = ffecom_sym_transform_ (s);
5965           t = ffesymbol_hook (s).decl_tree;     /* Sfunc expr non-dummy,
5966                                                    DIMENSION expr? */
5967         }
5968       break;                    /* Ok if (t == NULL) here. */
5969
5970     case FFEBLD_opITEM:
5971       ffecom_expr_transform_ (ffebld_head (expr));
5972       expr = ffebld_trail (expr);
5973       goto tail_recurse;        /* :::::::::::::::::::: */
5974
5975     default:
5976       break;
5977     }
5978
5979   switch (ffebld_arity (expr))
5980     {
5981     case 2:
5982       ffecom_expr_transform_ (ffebld_left (expr));
5983       expr = ffebld_right (expr);
5984       goto tail_recurse;        /* :::::::::::::::::::: */
5985
5986     case 1:
5987       expr = ffebld_left (expr);
5988       goto tail_recurse;        /* :::::::::::::::::::: */
5989
5990     default:
5991       break;
5992     }
5993
5994   return;
5995 }
5996
5997 #endif
5998 /* Make a type based on info in live f2c.h file.  */
5999
6000 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6001 static void
6002 ffecom_f2c_make_type_ (tree *type, int tcode, const char *name)
6003 {
6004   switch (tcode)
6005     {
6006     case FFECOM_f2ccodeCHAR:
6007       *type = make_signed_type (CHAR_TYPE_SIZE);
6008       break;
6009
6010     case FFECOM_f2ccodeSHORT:
6011       *type = make_signed_type (SHORT_TYPE_SIZE);
6012       break;
6013
6014     case FFECOM_f2ccodeINT:
6015       *type = make_signed_type (INT_TYPE_SIZE);
6016       break;
6017
6018     case FFECOM_f2ccodeLONG:
6019       *type = make_signed_type (LONG_TYPE_SIZE);
6020       break;
6021
6022     case FFECOM_f2ccodeLONGLONG:
6023       *type = make_signed_type (LONG_LONG_TYPE_SIZE);
6024       break;
6025
6026     case FFECOM_f2ccodeCHARPTR:
6027       *type = build_pointer_type (DEFAULT_SIGNED_CHAR
6028                                   ? signed_char_type_node
6029                                   : unsigned_char_type_node);
6030       break;
6031
6032     case FFECOM_f2ccodeFLOAT:
6033       *type = make_node (REAL_TYPE);
6034       TYPE_PRECISION (*type) = FLOAT_TYPE_SIZE;
6035       layout_type (*type);
6036       break;
6037
6038     case FFECOM_f2ccodeDOUBLE:
6039       *type = make_node (REAL_TYPE);
6040       TYPE_PRECISION (*type) = DOUBLE_TYPE_SIZE;
6041       layout_type (*type);
6042       break;
6043
6044     case FFECOM_f2ccodeLONGDOUBLE:
6045       *type = make_node (REAL_TYPE);
6046       TYPE_PRECISION (*type) = LONG_DOUBLE_TYPE_SIZE;
6047       layout_type (*type);
6048       break;
6049
6050     case FFECOM_f2ccodeTWOREALS:
6051       *type = ffecom_make_complex_type_ (ffecom_f2c_real_type_node);
6052       break;
6053
6054     case FFECOM_f2ccodeTWODOUBLEREALS:
6055       *type = ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node);
6056       break;
6057
6058     default:
6059       assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL);
6060       *type = error_mark_node;
6061       return;
6062     }
6063
6064   pushdecl (build_decl (TYPE_DECL,
6065                         ffecom_get_invented_identifier ("__g77_f2c_%s", name),
6066                         *type));
6067 }
6068
6069 #endif
6070 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6071 /* Set the f2c list-directed-I/O code for whatever (integral) type has the
6072    given size.  */
6073
6074 static void
6075 ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
6076                           int code)
6077 {
6078   int j;
6079   tree t;
6080
6081   for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
6082     if ((t = ffecom_tree_type[bt][j]) != NULL_TREE
6083         && compare_tree_int (TYPE_SIZE (t), size) == 0)
6084       {
6085         assert (code != -1);
6086         ffecom_f2c_typecode_[bt][j] = code;
6087         code = -1;
6088       }
6089 }
6090
6091 #endif
6092 /* Finish up globals after doing all program units in file
6093
6094    Need to handle only uninitialized COMMON areas.  */
6095
6096 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6097 static ffeglobal
6098 ffecom_finish_global_ (ffeglobal global)
6099 {
6100   tree cbtype;
6101   tree cbt;
6102   tree size;
6103
6104   if (ffeglobal_type (global) != FFEGLOBAL_typeCOMMON)
6105       return global;
6106
6107   if (ffeglobal_common_init (global))
6108       return global;
6109
6110   cbt = ffeglobal_hook (global);
6111   if ((cbt == NULL_TREE)
6112       || !ffeglobal_common_have_size (global))
6113     return global;              /* No need to make common, never ref'd. */
6114
6115   suspend_momentary ();
6116
6117   DECL_EXTERNAL (cbt) = 0;
6118
6119   /* Give the array a size now.  */
6120
6121   size = build_int_2 ((ffeglobal_common_size (global)
6122                       + ffeglobal_common_pad (global)) - 1,
6123                       0);
6124
6125   cbtype = TREE_TYPE (cbt);
6126   TYPE_DOMAIN (cbtype) = build_range_type (integer_type_node,
6127                                            integer_zero_node,
6128                                            size);
6129   if (!TREE_TYPE (size))
6130     TREE_TYPE (size) = TYPE_DOMAIN (cbtype);
6131   layout_type (cbtype);
6132
6133   cbt = start_decl (cbt, FALSE);
6134   assert (cbt == ffeglobal_hook (global));
6135
6136   finish_decl (cbt, NULL_TREE, FALSE);
6137
6138   return global;
6139 }
6140
6141 #endif
6142 /* Finish up any untransformed symbols.  */
6143
6144 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6145 static ffesymbol
6146 ffecom_finish_symbol_transform_ (ffesymbol s)
6147 {
6148   if ((s == NULL) || (TREE_CODE (current_function_decl) == ERROR_MARK))
6149     return s;
6150
6151   /* It's easy to know to transform an untransformed symbol, to make sure
6152      we put out debugging info for it.  But COMMON variables, unlike
6153      EQUIVALENCE ones, aren't given declarations in addition to the
6154      tree expressions that specify offsets, because COMMON variables
6155      can be referenced in the outer scope where only dummy arguments
6156      (PARM_DECLs) should really be seen.  To be safe, just don't do any
6157      VAR_DECLs for COMMON variables when we transform them for real
6158      use, and therefore we do all the VAR_DECL creating here.  */
6159
6160   if (ffesymbol_hook (s).decl_tree == NULL_TREE)
6161     {
6162       if (ffesymbol_kind (s) != FFEINFO_kindNONE
6163           || (ffesymbol_where (s) != FFEINFO_whereNONE
6164               && ffesymbol_where (s) != FFEINFO_whereINTRINSIC
6165               && ffesymbol_where (s) != FFEINFO_whereDUMMY))
6166         /* Not transformed, and not CHARACTER*(*), and not a dummy
6167            argument, which can happen only if the entry point names
6168            it "rides in on" are all invalidated for other reasons.  */
6169         s = ffecom_sym_transform_ (s);
6170     }
6171
6172   if ((ffesymbol_where (s) == FFEINFO_whereCOMMON)
6173       && (ffesymbol_hook (s).decl_tree != error_mark_node))
6174     {
6175       int yes = suspend_momentary ();
6176
6177       /* This isn't working, at least for dbxout.  The .s file looks
6178          okay to me (burley), but in gdb 4.9 at least, the variables
6179          appear to reside somewhere outside of the common area, so
6180          it doesn't make sense to mislead anyone by generating the info
6181          on those variables until this is fixed.  NOTE: Same problem
6182          with EQUIVALENCE, sadly...see similar #if later.  */
6183       ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s)),
6184                              ffesymbol_storage (s));
6185
6186       resume_momentary (yes);
6187     }
6188
6189   return s;
6190 }
6191
6192 #endif
6193 /* Append underscore(s) to name before calling get_identifier.  "us"
6194    is nonzero if the name already contains an underscore and thus
6195    needs two underscores appended.  */
6196
6197 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6198 static tree
6199 ffecom_get_appended_identifier_ (char us, const char *name)
6200 {
6201   int i;
6202   char *newname;
6203   tree id;
6204
6205   newname = xmalloc ((i = strlen (name)) + 1
6206                      + ffe_is_underscoring ()
6207                      + us);
6208   memcpy (newname, name, i);
6209   newname[i] = '_';
6210   newname[i + us] = '_';
6211   newname[i + 1 + us] = '\0';
6212   id = get_identifier (newname);
6213
6214   free (newname);
6215
6216   return id;
6217 }
6218
6219 #endif
6220 /* Decide whether to append underscore to name before calling
6221    get_identifier.  */
6222
6223 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6224 static tree
6225 ffecom_get_external_identifier_ (ffesymbol s)
6226 {
6227   char us;
6228   const char *name = ffesymbol_text (s);
6229
6230   /* If name is a built-in name, just return it as is.  */
6231
6232   if (!ffe_is_underscoring ()
6233       || (strcmp (name, FFETARGET_nameBLANK_COMMON) == 0)
6234 #if FFETARGET_isENFORCED_MAIN_NAME
6235       || (strcmp (name, FFETARGET_nameENFORCED_NAME) == 0)
6236 #else
6237       || (strcmp (name, FFETARGET_nameUNNAMED_MAIN) == 0)
6238 #endif
6239       || (strcmp (name, FFETARGET_nameUNNAMED_BLOCK_DATA) == 0))
6240     return get_identifier (name);
6241
6242   us = ffe_is_second_underscore ()
6243     ? (strchr (name, '_') != NULL)
6244       : 0;
6245
6246   return ffecom_get_appended_identifier_ (us, name);
6247 }
6248
6249 #endif
6250 /* Decide whether to append underscore to internal name before calling
6251    get_identifier.
6252
6253    This is for non-external, top-function-context names only.  Transform
6254    identifier so it doesn't conflict with the transformed result
6255    of using a _different_ external name.  E.g. if "CALL FOO" is
6256    transformed into "FOO_();", then the variable in "FOO_ = 3"
6257    must be transformed into something that does not conflict, since
6258    these two things should be independent.
6259
6260    The transformation is as follows.  If the name does not contain
6261    an underscore, there is no possible conflict, so just return.
6262    If the name does contain an underscore, then transform it just
6263    like we transform an external identifier.  */
6264
6265 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6266 static tree
6267 ffecom_get_identifier_ (const char *name)
6268 {
6269   /* If name does not contain an underscore, just return it as is.  */
6270
6271   if (!ffe_is_underscoring ()
6272       || (strchr (name, '_') == NULL))
6273     return get_identifier (name);
6274
6275   return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
6276                                           name);
6277 }
6278
6279 #endif
6280 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
6281
6282    tree t;
6283    ffesymbol s;  // kindFUNCTION, whereIMMEDIATE.
6284    t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
6285          ffesymbol_kindtype(s));
6286
6287    Call after setting up containing function and getting trees for all
6288    other symbols.  */
6289
6290 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6291 static tree
6292 ffecom_gen_sfuncdef_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt)
6293 {
6294   ffebld expr = ffesymbol_sfexpr (s);
6295   tree type;
6296   tree func;
6297   tree result;
6298   bool charfunc = (bt == FFEINFO_basictypeCHARACTER);
6299   static bool recurse = FALSE;
6300   int yes;
6301   int old_lineno = lineno;
6302   const char *old_input_filename = input_filename;
6303
6304   ffecom_nested_entry_ = s;
6305
6306   /* For now, we don't have a handy pointer to where the sfunc is actually
6307      defined, though that should be easy to add to an ffesymbol. (The
6308      token/where info available might well point to the place where the type
6309      of the sfunc is declared, especially if that precedes the place where
6310      the sfunc itself is defined, which is typically the case.)  We should
6311      put out a null pointer rather than point somewhere wrong, but I want to
6312      see how it works at this point.  */
6313
6314   input_filename = ffesymbol_where_filename (s);
6315   lineno = ffesymbol_where_filelinenum (s);
6316
6317   /* Pretransform the expression so any newly discovered things belong to the
6318      outer program unit, not to the statement function. */
6319
6320   ffecom_expr_transform_ (expr);
6321
6322   /* Make sure no recursive invocation of this fn (a specific case of failing
6323      to pretransform an sfunc's expression, i.e. where its expression
6324      references another untransformed sfunc) happens. */
6325
6326   assert (!recurse);
6327   recurse = TRUE;
6328
6329   yes = suspend_momentary ();
6330
6331   push_f_function_context ();
6332
6333   if (charfunc)
6334     type = void_type_node;
6335   else
6336     {
6337       type = ffecom_tree_type[bt][kt];
6338       if (type == NULL_TREE)
6339         type = integer_type_node;       /* _sym_exec_transition reports
6340                                            error. */
6341     }
6342
6343   start_function (ffecom_get_identifier_ (ffesymbol_text (s)),
6344                   build_function_type (type, NULL_TREE),
6345                   1,            /* nested/inline */
6346                   0);           /* TREE_PUBLIC */
6347
6348   /* We don't worry about COMPLEX return values here, because this is
6349      entirely internal to our code, and gcc has the ability to return COMPLEX
6350      directly as a value.  */
6351
6352   yes = suspend_momentary ();
6353
6354   if (charfunc)
6355     {                           /* Prepend arg for where result goes. */
6356       tree type;
6357
6358       type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
6359
6360       result = ffecom_get_invented_identifier ("__g77_%s", "result");
6361
6362       ffecom_char_enhance_arg_ (&type, s);      /* Ignore returned length. */
6363
6364       type = build_pointer_type (type);
6365       result = build_decl (PARM_DECL, result, type);
6366
6367       push_parm_decl (result);
6368     }
6369   else
6370     result = NULL_TREE;         /* Not ref'd if !charfunc. */
6371
6372   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s), TRUE);
6373
6374   resume_momentary (yes);
6375
6376   store_parm_decls (0);
6377
6378   ffecom_start_compstmt ();
6379
6380   if (expr != NULL)
6381     {
6382       if (charfunc)
6383         {
6384           ffetargetCharacterSize sz = ffesymbol_size (s);
6385           tree result_length;
6386
6387           result_length = build_int_2 (sz, 0);
6388           TREE_TYPE (result_length) = ffecom_f2c_ftnlen_type_node;
6389
6390           ffecom_prepare_let_char_ (sz, expr);
6391
6392           ffecom_prepare_end ();
6393
6394           ffecom_let_char_ (result, result_length, sz, expr);
6395           expand_null_return ();
6396         }
6397       else
6398         {
6399           ffecom_prepare_expr (expr);
6400
6401           ffecom_prepare_end ();
6402
6403           expand_return (ffecom_modify (NULL_TREE,
6404                                         DECL_RESULT (current_function_decl),
6405                                         ffecom_expr (expr)));
6406         }
6407
6408       clear_momentary ();
6409     }
6410
6411   ffecom_end_compstmt ();
6412
6413   func = current_function_decl;
6414   finish_function (1);
6415
6416   pop_f_function_context ();
6417
6418   resume_momentary (yes);
6419
6420   recurse = FALSE;
6421
6422   lineno = old_lineno;
6423   input_filename = old_input_filename;
6424
6425   ffecom_nested_entry_ = NULL;
6426
6427   return func;
6428 }
6429
6430 #endif
6431
6432 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6433 static const char *
6434 ffecom_gfrt_args_ (ffecomGfrt ix)
6435 {
6436   return ffecom_gfrt_argstring_[ix];
6437 }
6438
6439 #endif
6440 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6441 static tree
6442 ffecom_gfrt_tree_ (ffecomGfrt ix)
6443 {
6444   if (ffecom_gfrt_[ix] == NULL_TREE)
6445     ffecom_make_gfrt_ (ix);
6446
6447   return ffecom_1 (ADDR_EXPR,
6448                    build_pointer_type (TREE_TYPE (ffecom_gfrt_[ix])),
6449                    ffecom_gfrt_[ix]);
6450 }
6451
6452 #endif
6453 /* Return initialize-to-zero expression for this VAR_DECL.  */
6454
6455 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6456 /* A somewhat evil way to prevent the garbage collector
6457    from collecting 'tree' structures.  */
6458 #define NUM_TRACKED_CHUNK 63
6459 static struct tree_ggc_tracker
6460 {
6461   struct tree_ggc_tracker *next;
6462   tree trees[NUM_TRACKED_CHUNK];
6463 } *tracker_head = NULL;
6464
6465 static void
6466 mark_tracker_head (void *arg)
6467 {
6468   struct tree_ggc_tracker *head;
6469   int i;
6470
6471   for (head = * (struct tree_ggc_tracker **) arg;
6472        head != NULL;
6473        head = head->next)
6474   {
6475     ggc_mark (head);
6476     for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6477       ggc_mark_tree (head->trees[i]);
6478   }
6479 }
6480
6481 void
6482 ffecom_save_tree_forever (tree t)
6483 {
6484   int i;
6485   if (tracker_head != NULL)
6486     for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6487       if (tracker_head->trees[i] == NULL)
6488         {
6489           tracker_head->trees[i] = t;
6490           return;
6491         }
6492
6493   {
6494     /* Need to allocate a new block.  */
6495     struct tree_ggc_tracker *old_head = tracker_head;
6496
6497     tracker_head = ggc_alloc (sizeof (*tracker_head));
6498     tracker_head->next = old_head;
6499     tracker_head->trees[0] = t;
6500     for (i = 1; i < NUM_TRACKED_CHUNK; i++)
6501       tracker_head->trees[i] = NULL;
6502   }
6503 }
6504
6505 static tree
6506 ffecom_init_zero_ (tree decl)
6507 {
6508   tree init;
6509   int incremental = TREE_STATIC (decl);
6510   tree type = TREE_TYPE (decl);
6511
6512   if (incremental)
6513     {
6514       make_decl_rtl (decl, NULL, TREE_PUBLIC (decl) ? 1 : 0);
6515       assemble_variable (decl, TREE_PUBLIC (decl) ? 1 : 0, 0, 1);
6516     }
6517
6518   push_momentary ();
6519
6520   if ((TREE_CODE (type) != ARRAY_TYPE)
6521       && (TREE_CODE (type) != RECORD_TYPE)
6522       && (TREE_CODE (type) != UNION_TYPE)
6523       && !incremental)
6524     init = convert (type, integer_zero_node);
6525   else if (!incremental)
6526     {
6527       int momentary = suspend_momentary ();
6528
6529       init = build (CONSTRUCTOR, type, NULL_TREE, NULL_TREE);
6530       TREE_CONSTANT (init) = 1;
6531       TREE_STATIC (init) = 1;
6532
6533       resume_momentary (momentary);
6534     }
6535   else
6536     {
6537       int momentary = suspend_momentary ();
6538
6539       assemble_zeros (int_size_in_bytes (type));
6540       init = error_mark_node;
6541
6542       resume_momentary (momentary);
6543     }
6544
6545   pop_momentary_nofree ();
6546
6547   return init;
6548 }
6549
6550 #endif
6551 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6552 static tree
6553 ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
6554                          tree *maybe_tree)
6555 {
6556   tree expr_tree;
6557   tree length_tree;
6558
6559   switch (ffebld_op (arg))
6560     {
6561     case FFEBLD_opCONTER:       /* For F90, check 0-length. */
6562       if (ffetarget_length_character1
6563           (ffebld_constant_character1
6564            (ffebld_conter (arg))) == 0)
6565         {
6566           *maybe_tree = integer_zero_node;
6567           return convert (tree_type, integer_zero_node);
6568         }
6569
6570       *maybe_tree = integer_one_node;
6571       expr_tree = build_int_2 (*ffetarget_text_character1
6572                                (ffebld_constant_character1
6573                                 (ffebld_conter (arg))),
6574                                0);
6575       TREE_TYPE (expr_tree) = tree_type;
6576       return expr_tree;
6577
6578     case FFEBLD_opSYMTER:
6579     case FFEBLD_opARRAYREF:
6580     case FFEBLD_opFUNCREF:
6581     case FFEBLD_opSUBSTR:
6582       ffecom_char_args_ (&expr_tree, &length_tree, arg);
6583
6584       if ((expr_tree == error_mark_node)
6585           || (length_tree == error_mark_node))
6586         {
6587           *maybe_tree = error_mark_node;
6588           return error_mark_node;
6589         }
6590
6591       if (integer_zerop (length_tree))
6592         {
6593           *maybe_tree = integer_zero_node;
6594           return convert (tree_type, integer_zero_node);
6595         }
6596
6597       expr_tree
6598         = ffecom_1 (INDIRECT_REF,
6599                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6600                     expr_tree);
6601       expr_tree
6602         = ffecom_2 (ARRAY_REF,
6603                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6604                     expr_tree,
6605                     integer_one_node);
6606       expr_tree = convert (tree_type, expr_tree);
6607
6608       if (TREE_CODE (length_tree) == INTEGER_CST)
6609         *maybe_tree = integer_one_node;
6610       else                      /* Must check length at run time.  */
6611         *maybe_tree
6612           = ffecom_truth_value
6613             (ffecom_2 (GT_EXPR, integer_type_node,
6614                        length_tree,
6615                        ffecom_f2c_ftnlen_zero_node));
6616       return expr_tree;
6617
6618     case FFEBLD_opPAREN:
6619     case FFEBLD_opCONVERT:
6620       if (ffeinfo_size (ffebld_info (arg)) == 0)
6621         {
6622           *maybe_tree = integer_zero_node;
6623           return convert (tree_type, integer_zero_node);
6624         }
6625       return ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6626                                       maybe_tree);
6627
6628     case FFEBLD_opCONCATENATE:
6629       {
6630         tree maybe_left;
6631         tree maybe_right;
6632         tree expr_left;
6633         tree expr_right;
6634
6635         expr_left = ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6636                                              &maybe_left);
6637         expr_right = ffecom_intrinsic_ichar_ (tree_type, ffebld_right (arg),
6638                                               &maybe_right);
6639         *maybe_tree = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
6640                                 maybe_left,
6641                                 maybe_right);
6642         expr_tree = ffecom_3 (COND_EXPR, tree_type,
6643                               maybe_left,
6644                               expr_left,
6645                               expr_right);
6646         return expr_tree;
6647       }
6648
6649     default:
6650       assert ("bad op in ICHAR" == NULL);
6651       return error_mark_node;
6652     }
6653 }
6654
6655 #endif
6656 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
6657
6658    tree length_arg;
6659    ffebld expr;
6660    length_arg = ffecom_intrinsic_len_ (expr);
6661
6662    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
6663    subexpressions by constructing the appropriate tree for the
6664    length-of-character-text argument in a calling sequence.  */
6665
6666 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6667 static tree
6668 ffecom_intrinsic_len_ (ffebld expr)
6669 {
6670   ffetargetCharacter1 val;
6671   tree length;
6672
6673   switch (ffebld_op (expr))
6674     {
6675     case FFEBLD_opCONTER:
6676       val = ffebld_constant_character1 (ffebld_conter (expr));
6677       length = build_int_2 (ffetarget_length_character1 (val), 0);
6678       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6679       break;
6680
6681     case FFEBLD_opSYMTER:
6682       {
6683         ffesymbol s = ffebld_symter (expr);
6684         tree item;
6685
6686         item = ffesymbol_hook (s).decl_tree;
6687         if (item == NULL_TREE)
6688           {
6689             s = ffecom_sym_transform_ (s);
6690             item = ffesymbol_hook (s).decl_tree;
6691           }
6692         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
6693           {
6694             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
6695               length = ffesymbol_hook (s).length_tree;
6696             else
6697               {
6698                 length = build_int_2 (ffesymbol_size (s), 0);
6699                 TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6700               }
6701           }
6702         else if (item == error_mark_node)
6703           length = error_mark_node;
6704         else                    /* FFEINFO_kindFUNCTION: */
6705           length = NULL_TREE;
6706       }
6707       break;
6708
6709     case FFEBLD_opARRAYREF:
6710       length = ffecom_intrinsic_len_ (ffebld_left (expr));
6711       break;
6712
6713     case FFEBLD_opSUBSTR:
6714       {
6715         ffebld start;
6716         ffebld end;
6717         ffebld thing = ffebld_right (expr);
6718         tree start_tree;
6719         tree end_tree;
6720
6721         assert (ffebld_op (thing) == FFEBLD_opITEM);
6722         start = ffebld_head (thing);
6723         thing = ffebld_trail (thing);
6724         assert (ffebld_trail (thing) == NULL);
6725         end = ffebld_head (thing);
6726
6727         length = ffecom_intrinsic_len_ (ffebld_left (expr));
6728
6729         if (length == error_mark_node)
6730           break;
6731
6732         if (start == NULL)
6733           {
6734             if (end == NULL)
6735               ;
6736             else
6737               {
6738                 length = convert (ffecom_f2c_ftnlen_type_node,
6739                                   ffecom_expr (end));
6740               }
6741           }
6742         else
6743           {
6744             start_tree = convert (ffecom_f2c_ftnlen_type_node,
6745                                   ffecom_expr (start));
6746
6747             if (start_tree == error_mark_node)
6748               {
6749                 length = error_mark_node;
6750                 break;
6751               }
6752
6753             if (end == NULL)
6754               {
6755                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6756                                    ffecom_f2c_ftnlen_one_node,
6757                                    ffecom_2 (MINUS_EXPR,
6758                                              ffecom_f2c_ftnlen_type_node,
6759                                              length,
6760                                              start_tree));
6761               }
6762             else
6763               {
6764                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
6765                                     ffecom_expr (end));
6766
6767                 if (end_tree == error_mark_node)
6768                   {
6769                     length = error_mark_node;
6770                     break;
6771                   }
6772
6773                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6774                                    ffecom_f2c_ftnlen_one_node,
6775                                    ffecom_2 (MINUS_EXPR,
6776                                              ffecom_f2c_ftnlen_type_node,
6777                                              end_tree, start_tree));
6778               }
6779           }
6780       }
6781       break;
6782
6783     case FFEBLD_opCONCATENATE:
6784       length
6785         = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6786                     ffecom_intrinsic_len_ (ffebld_left (expr)),
6787                     ffecom_intrinsic_len_ (ffebld_right (expr)));
6788       break;
6789
6790     case FFEBLD_opFUNCREF:
6791     case FFEBLD_opCONVERT:
6792       length = build_int_2 (ffebld_size (expr), 0);
6793       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6794       break;
6795
6796     default:
6797       assert ("bad op for single char arg expr" == NULL);
6798       length = ffecom_f2c_ftnlen_zero_node;
6799       break;
6800     }
6801
6802   assert (length != NULL_TREE);
6803
6804   return length;
6805 }
6806
6807 #endif
6808 /* Handle CHARACTER assignments.
6809
6810    Generates code to do the assignment.  Used by ordinary assignment
6811    statement handler ffecom_let_stmt and by statement-function
6812    handler to generate code for a statement function.  */
6813
6814 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6815 static void
6816 ffecom_let_char_ (tree dest_tree, tree dest_length,
6817                   ffetargetCharacterSize dest_size, ffebld source)
6818 {
6819   ffecomConcatList_ catlist;
6820   tree source_length;
6821   tree source_tree;
6822   tree expr_tree;
6823
6824   if ((dest_tree == error_mark_node)
6825       || (dest_length == error_mark_node))
6826     return;
6827
6828   assert (dest_tree != NULL_TREE);
6829   assert (dest_length != NULL_TREE);
6830
6831   /* Source might be an opCONVERT, which just means it is a different size
6832      than the destination.  Since the underlying implementation here handles
6833      that (directly or via the s_copy or s_cat run-time-library functions),
6834      we don't need the "convenience" of an opCONVERT that tells us to
6835      truncate or blank-pad, particularly since the resulting implementation
6836      would probably be slower than otherwise. */
6837
6838   while (ffebld_op (source) == FFEBLD_opCONVERT)
6839     source = ffebld_left (source);
6840
6841   catlist = ffecom_concat_list_new_ (source, dest_size);
6842   switch (ffecom_concat_list_count_ (catlist))
6843     {
6844     case 0:                     /* Shouldn't happen, but in case it does... */
6845       ffecom_concat_list_kill_ (catlist);
6846       source_tree = null_pointer_node;
6847       source_length = ffecom_f2c_ftnlen_zero_node;
6848       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6849       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6850       TREE_CHAIN (TREE_CHAIN (expr_tree))
6851         = build_tree_list (NULL_TREE, dest_length);
6852       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6853         = build_tree_list (NULL_TREE, source_length);
6854
6855       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6856       TREE_SIDE_EFFECTS (expr_tree) = 1;
6857
6858       expand_expr_stmt (expr_tree);
6859
6860       return;
6861
6862     case 1:                     /* The (fairly) easy case. */
6863       ffecom_char_args_ (&source_tree, &source_length,
6864                          ffecom_concat_list_expr_ (catlist, 0));
6865       ffecom_concat_list_kill_ (catlist);
6866       assert (source_tree != NULL_TREE);
6867       assert (source_length != NULL_TREE);
6868
6869       if ((source_tree == error_mark_node)
6870           || (source_length == error_mark_node))
6871         return;
6872
6873       if (dest_size == 1)
6874         {
6875           dest_tree
6876             = ffecom_1 (INDIRECT_REF,
6877                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6878                                                       (dest_tree))),
6879                         dest_tree);
6880           dest_tree
6881             = ffecom_2 (ARRAY_REF,
6882                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6883                                                       (dest_tree))),
6884                         dest_tree,
6885                         integer_one_node);
6886           source_tree
6887             = ffecom_1 (INDIRECT_REF,
6888                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6889                                                       (source_tree))),
6890                         source_tree);
6891           source_tree
6892             = ffecom_2 (ARRAY_REF,
6893                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6894                                                       (source_tree))),
6895                         source_tree,
6896                         integer_one_node);
6897
6898           expr_tree = ffecom_modify (void_type_node, dest_tree, source_tree);
6899
6900           expand_expr_stmt (expr_tree);
6901
6902           return;
6903         }
6904
6905       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6906       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6907       TREE_CHAIN (TREE_CHAIN (expr_tree))
6908         = build_tree_list (NULL_TREE, dest_length);
6909       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6910         = build_tree_list (NULL_TREE, source_length);
6911
6912       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6913       TREE_SIDE_EFFECTS (expr_tree) = 1;
6914
6915       expand_expr_stmt (expr_tree);
6916
6917       return;
6918
6919     default:                    /* Must actually concatenate things. */
6920       break;
6921     }
6922
6923   /* Heavy-duty concatenation. */
6924
6925   {
6926     int count = ffecom_concat_list_count_ (catlist);
6927     int i;
6928     tree lengths;
6929     tree items;
6930     tree length_array;
6931     tree item_array;
6932     tree citem;
6933     tree clength;
6934
6935 #ifdef HOHO
6936     length_array
6937       = lengths
6938       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
6939                              FFETARGET_charactersizeNONE, count, TRUE);
6940     item_array = items = ffecom_push_tempvar (ffecom_f2c_address_type_node,
6941                                               FFETARGET_charactersizeNONE,
6942                                               count, TRUE);
6943 #else
6944     {
6945       tree hook;
6946
6947       hook = ffebld_nonter_hook (source);
6948       assert (hook);
6949       assert (TREE_CODE (hook) == TREE_VEC);
6950       assert (TREE_VEC_LENGTH (hook) == 2);
6951       length_array = lengths = TREE_VEC_ELT (hook, 0);
6952       item_array = items = TREE_VEC_ELT (hook, 1);
6953     }
6954 #endif
6955
6956     for (i = 0; i < count; ++i)
6957       {
6958         ffecom_char_args_ (&citem, &clength,
6959                            ffecom_concat_list_expr_ (catlist, i));
6960         if ((citem == error_mark_node)
6961             || (clength == error_mark_node))
6962           {
6963             ffecom_concat_list_kill_ (catlist);
6964             return;
6965           }
6966
6967         items
6968           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
6969                       ffecom_modify (void_type_node,
6970                                      ffecom_2 (ARRAY_REF,
6971                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
6972                                                item_array,
6973                                                build_int_2 (i, 0)),
6974                                      citem),
6975                       items);
6976         lengths
6977           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
6978                       ffecom_modify (void_type_node,
6979                                      ffecom_2 (ARRAY_REF,
6980                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
6981                                                length_array,
6982                                                build_int_2 (i, 0)),
6983                                      clength),
6984                       lengths);
6985       }
6986
6987     expr_tree = build_tree_list (NULL_TREE, dest_tree);
6988     TREE_CHAIN (expr_tree)
6989       = build_tree_list (NULL_TREE,
6990                          ffecom_1 (ADDR_EXPR,
6991                                    build_pointer_type (TREE_TYPE (items)),
6992                                    items));
6993     TREE_CHAIN (TREE_CHAIN (expr_tree))
6994       = build_tree_list (NULL_TREE,
6995                          ffecom_1 (ADDR_EXPR,
6996                                    build_pointer_type (TREE_TYPE (lengths)),
6997                                    lengths));
6998     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6999       = build_tree_list
7000         (NULL_TREE,
7001          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
7002                    convert (ffecom_f2c_ftnlen_type_node,
7003                             build_int_2 (count, 0))));
7004     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))))
7005       = build_tree_list (NULL_TREE, dest_length);
7006
7007     expr_tree = ffecom_call_gfrt (FFECOM_gfrtCAT, expr_tree, NULL_TREE);
7008     TREE_SIDE_EFFECTS (expr_tree) = 1;
7009
7010     expand_expr_stmt (expr_tree);
7011   }
7012
7013   ffecom_concat_list_kill_ (catlist);
7014 }
7015
7016 #endif
7017 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
7018
7019    ffecomGfrt ix;
7020    ffecom_make_gfrt_(ix);
7021
7022    Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
7023    for the indicated run-time routine (ix).  */
7024
7025 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7026 static void
7027 ffecom_make_gfrt_ (ffecomGfrt ix)
7028 {
7029   tree t;
7030   tree ttype;
7031
7032   switch (ffecom_gfrt_type_[ix])
7033     {
7034     case FFECOM_rttypeVOID_:
7035       ttype = void_type_node;
7036       break;
7037
7038     case FFECOM_rttypeVOIDSTAR_:
7039       ttype = TREE_TYPE (null_pointer_node);    /* `void *'. */
7040       break;
7041
7042     case FFECOM_rttypeFTNINT_:
7043       ttype = ffecom_f2c_ftnint_type_node;
7044       break;
7045
7046     case FFECOM_rttypeINTEGER_:
7047       ttype = ffecom_f2c_integer_type_node;
7048       break;
7049
7050     case FFECOM_rttypeLONGINT_:
7051       ttype = ffecom_f2c_longint_type_node;
7052       break;
7053
7054     case FFECOM_rttypeLOGICAL_:
7055       ttype = ffecom_f2c_logical_type_node;
7056       break;
7057
7058     case FFECOM_rttypeREAL_F2C_:
7059       ttype = double_type_node;
7060       break;
7061
7062     case FFECOM_rttypeREAL_GNU_:
7063       ttype = float_type_node;
7064       break;
7065
7066     case FFECOM_rttypeCOMPLEX_F2C_:
7067       ttype = void_type_node;
7068       break;
7069
7070     case FFECOM_rttypeCOMPLEX_GNU_:
7071       ttype = ffecom_f2c_complex_type_node;
7072       break;
7073
7074     case FFECOM_rttypeDOUBLE_:
7075       ttype = double_type_node;
7076       break;
7077
7078     case FFECOM_rttypeDOUBLEREAL_:
7079       ttype = ffecom_f2c_doublereal_type_node;
7080       break;
7081
7082     case FFECOM_rttypeDBLCMPLX_F2C_:
7083       ttype = void_type_node;
7084       break;
7085
7086     case FFECOM_rttypeDBLCMPLX_GNU_:
7087       ttype = ffecom_f2c_doublecomplex_type_node;
7088       break;
7089
7090     case FFECOM_rttypeCHARACTER_:
7091       ttype = void_type_node;
7092       break;
7093
7094     default:
7095       ttype = NULL;
7096       assert ("bad rttype" == NULL);
7097       break;
7098     }
7099
7100   ttype = build_function_type (ttype, NULL_TREE);
7101   t = build_decl (FUNCTION_DECL,
7102                   get_identifier (ffecom_gfrt_name_[ix]),
7103                   ttype);
7104   DECL_EXTERNAL (t) = 1;
7105   TREE_READONLY (t) = ffecom_gfrt_const_[ix] ? 1 : 0;
7106   TREE_PUBLIC (t) = 1;
7107   TREE_THIS_VOLATILE (t) = ffecom_gfrt_volatile_[ix] ? 1 : 0;
7108
7109   /* Sanity check:  A function that's const cannot be volatile.  */
7110
7111   assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_volatile_[ix] : 1);
7112
7113   /* Sanity check: A function that's const cannot return complex.  */
7114
7115   assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_complex_[ix] : 1);
7116
7117   t = start_decl (t, TRUE);
7118
7119   finish_decl (t, NULL_TREE, TRUE);
7120
7121   ffecom_gfrt_[ix] = t;
7122 }
7123
7124 #endif
7125 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group.  */
7126
7127 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7128 static void
7129 ffecom_member_phase1_ (ffestorag mst UNUSED, ffestorag st)
7130 {
7131   ffesymbol s = ffestorag_symbol (st);
7132
7133   if (ffesymbol_namelisted (s))
7134     ffecom_member_namelisted_ = TRUE;
7135 }
7136
7137 #endif
7138 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group.  Declare
7139    the member so debugger will see it.  Otherwise nobody should be
7140    referencing the member.  */
7141
7142 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7143 static void
7144 ffecom_member_phase2_ (ffestorag mst, ffestorag st)
7145 {
7146   ffesymbol s;
7147   tree t;
7148   tree mt;
7149   tree type;
7150
7151   if ((mst == NULL)
7152       || ((mt = ffestorag_hook (mst)) == NULL)
7153       || (mt == error_mark_node))
7154     return;
7155
7156   if ((st == NULL)
7157       || ((s = ffestorag_symbol (st)) == NULL))
7158     return;
7159
7160   type = ffecom_type_localvar_ (s,
7161                                 ffesymbol_basictype (s),
7162                                 ffesymbol_kindtype (s));
7163   if (type == error_mark_node)
7164     return;
7165
7166   t = build_decl (VAR_DECL,
7167                   ffecom_get_identifier_ (ffesymbol_text (s)),
7168                   type);
7169
7170   TREE_STATIC (t) = TREE_STATIC (mt);
7171   DECL_INITIAL (t) = NULL_TREE;
7172   TREE_ASM_WRITTEN (t) = 1;
7173
7174   DECL_RTL (t)
7175     = gen_rtx (MEM, TYPE_MODE (type),
7176                plus_constant (XEXP (DECL_RTL (mt), 0),
7177                               ffestorag_modulo (mst)
7178                               + ffestorag_offset (st)
7179                               - ffestorag_offset (mst)));
7180
7181   t = start_decl (t, FALSE);
7182
7183   finish_decl (t, NULL_TREE, FALSE);
7184 }
7185
7186 #endif
7187 /* Prepare source expression for assignment into a destination perhaps known
7188    to be of a specific size.  */
7189
7190 static void
7191 ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size, ffebld source)
7192 {
7193   ffecomConcatList_ catlist;
7194   int count;
7195   int i;
7196   tree ltmp;
7197   tree itmp;
7198   tree tempvar = NULL_TREE;
7199
7200   while (ffebld_op (source) == FFEBLD_opCONVERT)
7201     source = ffebld_left (source);
7202
7203   catlist = ffecom_concat_list_new_ (source, dest_size);
7204   count = ffecom_concat_list_count_ (catlist);
7205
7206   if (count >= 2)
7207     {
7208       ltmp
7209         = ffecom_make_tempvar ("let_char_len", ffecom_f2c_ftnlen_type_node,
7210                                FFETARGET_charactersizeNONE, count);
7211       itmp
7212         = ffecom_make_tempvar ("let_char_item", ffecom_f2c_address_type_node,
7213                                FFETARGET_charactersizeNONE, count);
7214
7215       tempvar = make_tree_vec (2);
7216       TREE_VEC_ELT (tempvar, 0) = ltmp;
7217       TREE_VEC_ELT (tempvar, 1) = itmp;
7218     }
7219
7220   for (i = 0; i < count; ++i)
7221     ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist, i));
7222
7223   ffecom_concat_list_kill_ (catlist);
7224
7225   if (tempvar)
7226     {
7227       ffebld_nonter_set_hook (source, tempvar);
7228       current_binding_level->prep_state = 1;
7229     }
7230 }
7231
7232 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
7233
7234    Ignores STAR (alternate-return) dummies.  All other get exec-transitioned
7235    (which generates their trees) and then their trees get push_parm_decl'd.
7236
7237    The second arg is TRUE if the dummies are for a statement function, in
7238    which case lengths are not pushed for character arguments (since they are
7239    always known by both the caller and the callee, though the code allows
7240    for someday permitting CHAR*(*) stmtfunc dummies).  */
7241
7242 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7243 static void
7244 ffecom_push_dummy_decls_ (ffebld dummy_list, bool stmtfunc)
7245 {
7246   ffebld dummy;
7247   ffebld dumlist;
7248   ffesymbol s;
7249   tree parm;
7250
7251   ffecom_transform_only_dummies_ = TRUE;
7252
7253   /* First push the parms corresponding to actual dummy "contents".  */
7254
7255   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7256     {
7257       dummy = ffebld_head (dumlist);
7258       switch (ffebld_op (dummy))
7259         {
7260         case FFEBLD_opSTAR:
7261         case FFEBLD_opANY:
7262           continue;             /* Forget alternate returns. */
7263
7264         default:
7265           break;
7266         }
7267       assert (ffebld_op (dummy) == FFEBLD_opSYMTER);
7268       s = ffebld_symter (dummy);
7269       parm = ffesymbol_hook (s).decl_tree;
7270       if (parm == NULL_TREE)
7271         {
7272           s = ffecom_sym_transform_ (s);
7273           parm = ffesymbol_hook (s).decl_tree;
7274           assert (parm != NULL_TREE);
7275         }
7276       if (parm != error_mark_node)
7277         push_parm_decl (parm);
7278     }
7279
7280   /* Then, for CHARACTER dummies, push the parms giving their lengths.  */
7281
7282   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7283     {
7284       dummy = ffebld_head (dumlist);
7285       switch (ffebld_op (dummy))
7286         {
7287         case FFEBLD_opSTAR:
7288         case FFEBLD_opANY:
7289           continue;             /* Forget alternate returns, they mean
7290                                    NOTHING! */
7291
7292         default:
7293           break;
7294         }
7295       s = ffebld_symter (dummy);
7296       if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
7297         continue;               /* Only looking for CHARACTER arguments. */
7298       if (stmtfunc && (ffesymbol_size (s) != FFETARGET_charactersizeNONE))
7299         continue;               /* Stmtfunc arg with known size needs no
7300                                    length param. */
7301       if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
7302         continue;               /* Only looking for variables and arrays. */
7303       parm = ffesymbol_hook (s).length_tree;
7304       assert (parm != NULL_TREE);
7305       if (parm != error_mark_node)
7306         push_parm_decl (parm);
7307     }
7308
7309   ffecom_transform_only_dummies_ = FALSE;
7310 }
7311
7312 #endif
7313 /* ffecom_start_progunit_ -- Beginning of program unit
7314
7315    Does GNU back end stuff necessary to teach it about the start of its
7316    equivalent of a Fortran program unit.  */
7317
7318 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7319 static void
7320 ffecom_start_progunit_ ()
7321 {
7322   ffesymbol fn = ffecom_primary_entry_;
7323   ffebld arglist;
7324   tree id;                      /* Identifier (name) of function. */
7325   tree type;                    /* Type of function. */
7326   tree result;                  /* Result of function. */
7327   ffeinfoBasictype bt;
7328   ffeinfoKindtype kt;
7329   ffeglobal g;
7330   ffeglobalType gt;
7331   ffeglobalType egt = FFEGLOBAL_type;
7332   bool charfunc;
7333   bool cmplxfunc;
7334   bool altentries = (ffecom_num_entrypoints_ != 0);
7335   bool multi
7336   = altentries
7337   && (ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
7338   && (ffecom_master_bt_ == FFEINFO_basictypeNONE);
7339   bool main_program = FALSE;
7340   int old_lineno = lineno;
7341   const char *old_input_filename = input_filename;
7342   int yes;
7343
7344   assert (fn != NULL);
7345   assert (ffesymbol_hook (fn).decl_tree == NULL_TREE);
7346
7347   input_filename = ffesymbol_where_filename (fn);
7348   lineno = ffesymbol_where_filelinenum (fn);
7349
7350   /* c-parse.y indeed does call suspend_momentary and not only ignores the
7351      return value, but also never calls resume_momentary, when starting an
7352      outer function (see "fndef:", "setspecs:", and so on).  So g77 does the
7353      same thing.  It shouldn't be a problem since start_function calls
7354      temporary_allocation, but it might be necessary.  If it causes a problem
7355      here, then maybe there's a bug lurking in gcc.  NOTE: This identical
7356      comment appears twice in thist file.  */
7357
7358   suspend_momentary ();
7359
7360   switch (ffecom_primary_entry_kind_)
7361     {
7362     case FFEINFO_kindPROGRAM:
7363       main_program = TRUE;
7364       gt = FFEGLOBAL_typeMAIN;
7365       bt = FFEINFO_basictypeNONE;
7366       kt = FFEINFO_kindtypeNONE;
7367       type = ffecom_tree_fun_type_void;
7368       charfunc = FALSE;
7369       cmplxfunc = FALSE;
7370       break;
7371
7372     case FFEINFO_kindBLOCKDATA:
7373       gt = FFEGLOBAL_typeBDATA;
7374       bt = FFEINFO_basictypeNONE;
7375       kt = FFEINFO_kindtypeNONE;
7376       type = ffecom_tree_fun_type_void;
7377       charfunc = FALSE;
7378       cmplxfunc = FALSE;
7379       break;
7380
7381     case FFEINFO_kindFUNCTION:
7382       gt = FFEGLOBAL_typeFUNC;
7383       egt = FFEGLOBAL_typeEXT;
7384       bt = ffesymbol_basictype (fn);
7385       kt = ffesymbol_kindtype (fn);
7386       if (bt == FFEINFO_basictypeNONE)
7387         {
7388           ffeimplic_establish_symbol (fn);
7389           if (ffesymbol_funcresult (fn) != NULL)
7390             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
7391           bt = ffesymbol_basictype (fn);
7392           kt = ffesymbol_kindtype (fn);
7393         }
7394
7395       if (multi)
7396         charfunc = cmplxfunc = FALSE;
7397       else if (bt == FFEINFO_basictypeCHARACTER)
7398         charfunc = TRUE, cmplxfunc = FALSE;
7399       else if ((bt == FFEINFO_basictypeCOMPLEX)
7400                && ffesymbol_is_f2c (fn)
7401                && !altentries)
7402         charfunc = FALSE, cmplxfunc = TRUE;
7403       else
7404         charfunc = cmplxfunc = FALSE;
7405
7406       if (multi || charfunc)
7407         type = ffecom_tree_fun_type_void;
7408       else if (ffesymbol_is_f2c (fn) && !altentries)
7409         type = ffecom_tree_fun_type[bt][kt];
7410       else
7411         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
7412
7413       if ((type == NULL_TREE)
7414           || (TREE_TYPE (type) == NULL_TREE))
7415         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
7416       break;
7417
7418     case FFEINFO_kindSUBROUTINE:
7419       gt = FFEGLOBAL_typeSUBR;
7420       egt = FFEGLOBAL_typeEXT;
7421       bt = FFEINFO_basictypeNONE;
7422       kt = FFEINFO_kindtypeNONE;
7423       if (ffecom_is_altreturning_)
7424         type = ffecom_tree_subr_type;
7425       else
7426         type = ffecom_tree_fun_type_void;
7427       charfunc = FALSE;
7428       cmplxfunc = FALSE;
7429       break;
7430
7431     default:
7432       assert ("say what??" == NULL);
7433       /* Fall through. */
7434     case FFEINFO_kindANY:
7435       gt = FFEGLOBAL_typeANY;
7436       bt = FFEINFO_basictypeNONE;
7437       kt = FFEINFO_kindtypeNONE;
7438       type = error_mark_node;
7439       charfunc = FALSE;
7440       cmplxfunc = FALSE;
7441       break;
7442     }
7443
7444   if (altentries)
7445     {
7446       id = ffecom_get_invented_identifier ("__g77_masterfun_%s",
7447                                            ffesymbol_text (fn));
7448     }
7449 #if FFETARGET_isENFORCED_MAIN
7450   else if (main_program)
7451     id = get_identifier (FFETARGET_nameENFORCED_MAIN_NAME);
7452 #endif
7453   else
7454     id = ffecom_get_external_identifier_ (fn);
7455
7456   start_function (id,
7457                   type,
7458                   0,            /* nested/inline */
7459                   !altentries); /* TREE_PUBLIC */
7460
7461   TREE_USED (current_function_decl) = 1;        /* Avoid spurious warning if altentries. */
7462
7463   if (!altentries
7464       && ((g = ffesymbol_global (fn)) != NULL)
7465       && ((ffeglobal_type (g) == gt)
7466           || (ffeglobal_type (g) == egt)))
7467     {
7468       ffeglobal_set_hook (g, current_function_decl);
7469     }
7470
7471   yes = suspend_momentary ();
7472
7473   /* Arg handling needs exec-transitioned ffesymbols to work with.  But
7474      exec-transitioning needs current_function_decl to be filled in.  So we
7475      do these things in two phases. */
7476
7477   if (altentries)
7478     {                           /* 1st arg identifies which entrypoint. */
7479       ffecom_which_entrypoint_decl_
7480         = build_decl (PARM_DECL,
7481                       ffecom_get_invented_identifier ("__g77_%s",
7482                                                       "which_entrypoint"),
7483                       integer_type_node);
7484       push_parm_decl (ffecom_which_entrypoint_decl_);
7485     }
7486
7487   if (charfunc
7488       || cmplxfunc
7489       || multi)
7490     {                           /* Arg for result (return value). */
7491       tree type;
7492       tree length;
7493
7494       if (charfunc)
7495         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
7496       else if (cmplxfunc)
7497         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
7498       else
7499         type = ffecom_multi_type_node_;
7500
7501       result = ffecom_get_invented_identifier ("__g77_%s", "result");
7502
7503       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
7504
7505       if (charfunc)
7506         length = ffecom_char_enhance_arg_ (&type, fn);
7507       else
7508         length = NULL_TREE;     /* Not ref'd if !charfunc. */
7509
7510       type = build_pointer_type (type);
7511       result = build_decl (PARM_DECL, result, type);
7512
7513       push_parm_decl (result);
7514       if (multi)
7515         ffecom_multi_retval_ = result;
7516       else
7517         ffecom_func_result_ = result;
7518
7519       if (charfunc)
7520         {
7521           push_parm_decl (length);
7522           ffecom_func_length_ = length;
7523         }
7524     }
7525
7526   if (ffecom_primary_entry_is_proc_)
7527     {
7528       if (altentries)
7529         arglist = ffecom_master_arglist_;
7530       else
7531         arglist = ffesymbol_dummyargs (fn);
7532       ffecom_push_dummy_decls_ (arglist, FALSE);
7533     }
7534
7535   resume_momentary (yes);
7536
7537   if (TREE_CODE (current_function_decl) != ERROR_MARK)
7538     store_parm_decls (main_program ? 1 : 0);
7539
7540   ffecom_start_compstmt ();
7541   /* Disallow temp vars at this level.  */
7542   current_binding_level->prep_state = 2;
7543
7544   lineno = old_lineno;
7545   input_filename = old_input_filename;
7546
7547   /* This handles any symbols still untransformed, in case -g specified.
7548      This used to be done in ffecom_finish_progunit, but it turns out to
7549      be necessary to do it here so that statement functions are
7550      expanded before code.  But don't bother for BLOCK DATA.  */
7551
7552   if (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
7553     ffesymbol_drive (ffecom_finish_symbol_transform_);
7554 }
7555
7556 #endif
7557 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
7558
7559    ffesymbol s;
7560    ffecom_sym_transform_(s);
7561
7562    The ffesymbol_hook info for s is updated with appropriate backend info
7563    on the symbol.  */
7564
7565 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7566 static ffesymbol
7567 ffecom_sym_transform_ (ffesymbol s)
7568 {
7569   tree t;                       /* Transformed thingy. */
7570   tree tlen;                    /* Length if CHAR*(*). */
7571   bool addr;                    /* Is t the address of the thingy? */
7572   ffeinfoBasictype bt;
7573   ffeinfoKindtype kt;
7574   ffeglobal g;
7575   int yes;
7576   int old_lineno = lineno;
7577   const char *old_input_filename = input_filename;
7578
7579   /* Must ensure special ASSIGN variables are declared at top of outermost
7580      block, else they'll end up in the innermost block when their first
7581      ASSIGN is seen, which leaves them out of scope when they're the
7582      subject of a GOTO or I/O statement.
7583
7584      We make this variable even if -fugly-assign.  Just let it go unused,
7585      in case it turns out there are cases where we really want to use this
7586      variable anyway (e.g. ASSIGN to INTEGER*2 variable).  */
7587
7588   if (! ffecom_transform_only_dummies_
7589       && ffesymbol_assigned (s)
7590       && ! ffesymbol_hook (s).assign_tree)
7591     s = ffecom_sym_transform_assign_ (s);
7592
7593   if (ffesymbol_sfdummyparent (s) == NULL)
7594     {
7595       input_filename = ffesymbol_where_filename (s);
7596       lineno = ffesymbol_where_filelinenum (s);
7597     }
7598   else
7599     {
7600       ffesymbol sf = ffesymbol_sfdummyparent (s);
7601
7602       input_filename = ffesymbol_where_filename (sf);
7603       lineno = ffesymbol_where_filelinenum (sf);
7604     }
7605
7606   bt = ffeinfo_basictype (ffebld_info (s));
7607   kt = ffeinfo_kindtype (ffebld_info (s));
7608
7609   t = NULL_TREE;
7610   tlen = NULL_TREE;
7611   addr = FALSE;
7612
7613   switch (ffesymbol_kind (s))
7614     {
7615     case FFEINFO_kindNONE:
7616       switch (ffesymbol_where (s))
7617         {
7618         case FFEINFO_whereDUMMY:        /* Subroutine or function. */
7619           assert (ffecom_transform_only_dummies_);
7620
7621           /* Before 0.4, this could be ENTITY/DUMMY, but see
7622              ffestu_sym_end_transition -- no longer true (in particular, if
7623              it could be an ENTITY, it _will_ be made one, so that
7624              possibility won't come through here).  So we never make length
7625              arg for CHARACTER type.  */
7626
7627           t = build_decl (PARM_DECL,
7628                           ffecom_get_identifier_ (ffesymbol_text (s)),
7629                           ffecom_tree_ptr_to_subr_type);
7630 #if BUILT_FOR_270
7631           DECL_ARTIFICIAL (t) = 1;
7632 #endif
7633           addr = TRUE;
7634           break;
7635
7636         case FFEINFO_whereGLOBAL:       /* Subroutine or function. */
7637           assert (!ffecom_transform_only_dummies_);
7638
7639           if (((g = ffesymbol_global (s)) != NULL)
7640               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7641                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7642                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
7643               && (ffeglobal_hook (g) != NULL_TREE)
7644               && ffe_is_globals ())
7645             {
7646               t = ffeglobal_hook (g);
7647               break;
7648             }
7649
7650           t = build_decl (FUNCTION_DECL,
7651                           ffecom_get_external_identifier_ (s),
7652                           ffecom_tree_subr_type);       /* Assume subr. */
7653           DECL_EXTERNAL (t) = 1;
7654           TREE_PUBLIC (t) = 1;
7655
7656           t = start_decl (t, FALSE);
7657           finish_decl (t, NULL_TREE, FALSE);
7658
7659           if ((g != NULL)
7660               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7661                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7662                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
7663             ffeglobal_set_hook (g, t);
7664
7665           ffecom_save_tree_forever (t);
7666
7667           break;
7668
7669         default:
7670           assert ("NONE where unexpected" == NULL);
7671           /* Fall through. */
7672         case FFEINFO_whereANY:
7673           break;
7674         }
7675       break;
7676
7677     case FFEINFO_kindENTITY:
7678       switch (ffeinfo_where (ffesymbol_info (s)))
7679         {
7680
7681         case FFEINFO_whereCONSTANT:
7682           /* ~~Debugging info needed? */
7683           assert (!ffecom_transform_only_dummies_);
7684           t = error_mark_node;  /* Shouldn't ever see this in expr. */
7685           break;
7686
7687         case FFEINFO_whereLOCAL:
7688           assert (!ffecom_transform_only_dummies_);
7689
7690           {
7691             ffestorag st = ffesymbol_storage (s);
7692             tree type;
7693
7694             if ((st != NULL)
7695                 && (ffestorag_size (st) == 0))
7696               {
7697                 t = error_mark_node;
7698                 break;
7699               }
7700
7701             yes = suspend_momentary ();
7702             type = ffecom_type_localvar_ (s, bt, kt);
7703             resume_momentary (yes);
7704
7705             if (type == error_mark_node)
7706               {
7707                 t = error_mark_node;
7708                 break;
7709               }
7710
7711             if ((st != NULL)
7712                 && (ffestorag_parent (st) != NULL))
7713               {                 /* Child of EQUIVALENCE parent. */
7714                 ffestorag est;
7715                 tree et;
7716                 int yes;
7717                 ffetargetOffset offset;
7718
7719                 est = ffestorag_parent (st);
7720                 ffecom_transform_equiv_ (est);
7721
7722                 et = ffestorag_hook (est);
7723                 assert (et != NULL_TREE);
7724
7725                 if (! TREE_STATIC (et))
7726                   put_var_into_stack (et);
7727
7728                 yes = suspend_momentary ();
7729
7730                 offset = ffestorag_modulo (est)
7731                   + ffestorag_offset (ffesymbol_storage (s))
7732                   - ffestorag_offset (est);
7733
7734                 ffecom_debug_kludge_ (et, "EQUIVALENCE", s, type, offset);
7735
7736                 /* (t_type *) (((char *) &et) + offset) */
7737
7738                 t = convert (string_type_node,  /* (char *) */
7739                              ffecom_1 (ADDR_EXPR,
7740                                        build_pointer_type (TREE_TYPE (et)),
7741                                        et));
7742                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
7743                               t,
7744                               build_int_2 (offset, 0));
7745                 t = convert (build_pointer_type (type),
7746                              t);
7747                 TREE_CONSTANT (t) = staticp (et);
7748
7749                 addr = TRUE;
7750
7751                 resume_momentary (yes);
7752               }
7753             else
7754               {
7755                 tree initexpr;
7756                 bool init = ffesymbol_is_init (s);
7757
7758                 yes = suspend_momentary ();
7759
7760                 t = build_decl (VAR_DECL,
7761                                 ffecom_get_identifier_ (ffesymbol_text (s)),
7762                                 type);
7763
7764                 if (init
7765                     || ffesymbol_namelisted (s)
7766 #ifdef FFECOM_sizeMAXSTACKITEM
7767                     || ((st != NULL)
7768                         && (ffestorag_size (st) > FFECOM_sizeMAXSTACKITEM))
7769 #endif
7770                     || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
7771                         && (ffecom_primary_entry_kind_
7772                             != FFEINFO_kindBLOCKDATA)
7773                         && (ffesymbol_is_save (s) || ffe_is_saveall ())))
7774                   TREE_STATIC (t) = !ffesymbol_attr (s, FFESYMBOL_attrADJUSTABLE);
7775                 else
7776                   TREE_STATIC (t) = 0;  /* No need to make static. */
7777
7778                 if (init || ffe_is_init_local_zero ())
7779                   DECL_INITIAL (t) = error_mark_node;
7780
7781                 /* Keep -Wunused from complaining about var if it
7782                    is used as sfunc arg or DATA implied-DO.  */
7783                 if (ffesymbol_attrs (s) & FFESYMBOL_attrsSFARG)
7784                   DECL_IN_SYSTEM_HEADER (t) = 1;
7785
7786                 t = start_decl (t, FALSE);
7787
7788                 if (init)
7789                   {
7790                     if (ffesymbol_init (s) != NULL)
7791                       initexpr = ffecom_expr (ffesymbol_init (s));
7792                     else
7793                       initexpr = ffecom_init_zero_ (t);
7794                   }
7795                 else if (ffe_is_init_local_zero ())
7796                   initexpr = ffecom_init_zero_ (t);
7797                 else
7798                   initexpr = NULL_TREE; /* Not ref'd if !init. */
7799
7800                 finish_decl (t, initexpr, FALSE);
7801
7802                 if (st != NULL && DECL_SIZE (t) != error_mark_node)
7803                   {
7804                     assert (TREE_CODE (DECL_SIZE_UNIT (t)) == INTEGER_CST);
7805                     assert (0 == compare_tree_int (DECL_SIZE_UNIT (t),
7806                                                    ffestorag_size (st)));
7807                   }
7808
7809                 resume_momentary (yes);
7810               }
7811           }
7812           break;
7813
7814         case FFEINFO_whereRESULT:
7815           assert (!ffecom_transform_only_dummies_);
7816
7817           if (bt == FFEINFO_basictypeCHARACTER)
7818             {                   /* Result is already in list of dummies, use
7819                                    it (& length). */
7820               t = ffecom_func_result_;
7821               tlen = ffecom_func_length_;
7822               addr = TRUE;
7823               break;
7824             }
7825           if ((ffecom_num_entrypoints_ == 0)
7826               && (bt == FFEINFO_basictypeCOMPLEX)
7827               && (ffesymbol_is_f2c (ffecom_primary_entry_)))
7828             {                   /* Result is already in list of dummies, use
7829                                    it. */
7830               t = ffecom_func_result_;
7831               addr = TRUE;
7832               break;
7833             }
7834           if (ffecom_func_result_ != NULL_TREE)
7835             {
7836               t = ffecom_func_result_;
7837               break;
7838             }
7839           if ((ffecom_num_entrypoints_ != 0)
7840               && (ffecom_master_bt_ == FFEINFO_basictypeNONE))
7841             {
7842               yes = suspend_momentary ();
7843
7844               assert (ffecom_multi_retval_ != NULL_TREE);
7845               t = ffecom_1 (INDIRECT_REF, ffecom_multi_type_node_,
7846                             ffecom_multi_retval_);
7847               t = ffecom_2 (COMPONENT_REF, ffecom_tree_type[bt][kt],
7848                             t, ffecom_multi_fields_[bt][kt]);
7849
7850               resume_momentary (yes);
7851               break;
7852             }
7853
7854           yes = suspend_momentary ();
7855
7856           t = build_decl (VAR_DECL,
7857                           ffecom_get_identifier_ (ffesymbol_text (s)),
7858                           ffecom_tree_type[bt][kt]);
7859           TREE_STATIC (t) = 0;  /* Put result on stack. */
7860           t = start_decl (t, FALSE);
7861           finish_decl (t, NULL_TREE, FALSE);
7862
7863           ffecom_func_result_ = t;
7864
7865           resume_momentary (yes);
7866           break;
7867
7868         case FFEINFO_whereDUMMY:
7869           {
7870             tree type;
7871             ffebld dl;
7872             ffebld dim;
7873             tree low;
7874             tree high;
7875             tree old_sizes;
7876             bool adjustable = FALSE;    /* Conditionally adjustable? */
7877
7878             type = ffecom_tree_type[bt][kt];
7879             if (ffesymbol_sfdummyparent (s) != NULL)
7880               {
7881                 if (current_function_decl == ffecom_outer_function_decl_)
7882                   {                     /* Exec transition before sfunc
7883                                            context; get it later. */
7884                     break;
7885                   }
7886                 t = ffecom_get_identifier_ (ffesymbol_text
7887                                             (ffesymbol_sfdummyparent (s)));
7888               }
7889             else
7890               t = ffecom_get_identifier_ (ffesymbol_text (s));
7891
7892             assert (ffecom_transform_only_dummies_);
7893
7894             old_sizes = get_pending_sizes ();
7895             put_pending_sizes (old_sizes);
7896
7897             if (bt == FFEINFO_basictypeCHARACTER)
7898               tlen = ffecom_char_enhance_arg_ (&type, s);
7899             type = ffecom_check_size_overflow_ (s, type, TRUE);
7900
7901             for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
7902               {
7903                 if (type == error_mark_node)
7904                   break;
7905
7906                 dim = ffebld_head (dl);
7907                 assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
7908                 if ((ffebld_left (dim) == NULL) || ffecom_doing_entry_)
7909                   low = ffecom_integer_one_node;
7910                 else
7911                   low = ffecom_expr (ffebld_left (dim));
7912                 assert (ffebld_right (dim) != NULL);
7913                 if ((ffebld_op (ffebld_right (dim)) == FFEBLD_opSTAR)
7914                     || ffecom_doing_entry_)
7915                   {
7916                     /* Used to just do high=low.  But for ffecom_tree_
7917                        canonize_ref_, it probably is important to correctly
7918                        assess the size.  E.g. given COMPLEX C(*),CFUNC and
7919                        C(2)=CFUNC(C), overlap can happen, while it can't
7920                        for, say, C(1)=CFUNC(C(2)).  */
7921                     /* Even more recently used to set to INT_MAX, but that
7922                        broke when some overflow checking went into the back
7923                        end.  Now we just leave the upper bound unspecified.  */
7924                     high = NULL;
7925                   }
7926                 else
7927                   high = ffecom_expr (ffebld_right (dim));
7928
7929                 /* Determine whether array is conditionally adjustable,
7930                    to decide whether back-end magic is needed.
7931
7932                    Normally the front end uses the back-end function
7933                    variable_size to wrap SAVE_EXPR's around expressions
7934                    affecting the size/shape of an array so that the
7935                    size/shape info doesn't change during execution
7936                    of the compiled code even though variables and
7937                    functions referenced in those expressions might.
7938
7939                    variable_size also makes sure those saved expressions
7940                    get evaluated immediately upon entry to the
7941                    compiled procedure -- the front end normally doesn't
7942                    have to worry about that.
7943
7944                    However, there is a problem with this that affects
7945                    g77's implementation of entry points, and that is
7946                    that it is _not_ true that each invocation of the
7947                    compiled procedure is permitted to evaluate
7948                    array size/shape info -- because it is possible
7949                    that, for some invocations, that info is invalid (in
7950                    which case it is "promised" -- i.e. a violation of
7951                    the Fortran standard -- that the compiled code
7952                    won't reference the array or its size/shape
7953                    during that particular invocation).
7954
7955                    To phrase this in C terms, consider this gcc function:
7956
7957                      void foo (int *n, float (*a)[*n])
7958                      {
7959                        // a is "pointer to array ...", fyi.
7960                      }
7961
7962                    Suppose that, for some invocations, it is permitted
7963                    for a caller of foo to do this:
7964
7965                        foo (NULL, NULL);
7966
7967                    Now the _written_ code for foo can take such a call
7968                    into account by either testing explicitly for whether
7969                    (a == NULL) || (n == NULL) -- presumably it is
7970                    not permitted to reference *a in various fashions
7971                    if (n == NULL) I suppose -- or it can avoid it by
7972                    looking at other info (other arguments, static/global
7973                    data, etc.).
7974
7975                    However, this won't work in gcc 2.5.8 because it'll
7976                    automatically emit the code to save the "*n"
7977                    expression, which'll yield a NULL dereference for
7978                    the "foo (NULL, NULL)" call, something the code
7979                    for foo cannot prevent.
7980
7981                    g77 definitely needs to avoid executing such
7982                    code anytime the pointer to the adjustable array
7983                    is NULL, because even if its bounds expressions
7984                    don't have any references to possible "absent"
7985                    variables like "*n" -- say all variable references
7986                    are to COMMON variables, i.e. global (though in C,
7987                    local static could actually make sense) -- the
7988                    expressions could yield other run-time problems
7989                    for allowably "dead" values in those variables.
7990
7991                    For example, let's consider a more complicated
7992                    version of foo:
7993
7994                      extern int i;
7995                      extern int j;
7996
7997                      void foo (float (*a)[i/j])
7998                      {
7999                        ...
8000                      }
8001
8002                    The above is (essentially) quite valid for Fortran
8003                    but, again, for a call like "foo (NULL);", it is
8004                    permitted for i and j to be undefined when the
8005                    call is made.  If j happened to be zero, for
8006                    example, emitting the code to evaluate "i/j"
8007                    could result in a run-time error.
8008
8009                    Offhand, though I don't have my F77 or F90
8010                    standards handy, it might even be valid for a
8011                    bounds expression to contain a function reference,
8012                    in which case I doubt it is permitted for an
8013                    implementation to invoke that function in the
8014                    Fortran case involved here (invocation of an
8015                    alternate ENTRY point that doesn't have the adjustable
8016                    array as one of its arguments).
8017
8018                    So, the code that the compiler would normally emit
8019                    to preevaluate the size/shape info for an
8020                    adjustable array _must not_ be executed at run time
8021                    in certain cases.  Specifically, for Fortran,
8022                    the case is when the pointer to the adjustable
8023                    array == NULL.  (For gnu-ish C, it might be nice
8024                    for the source code itself to specify an expression
8025                    that, if TRUE, inhibits execution of the code.  Or
8026                    reverse the sense for elegance.)
8027
8028                    (Note that g77 could use a different test than NULL,
8029                    actually, since it happens to always pass an
8030                    integer to the called function that specifies which
8031                    entry point is being invoked.  Hmm, this might
8032                    solve the next problem.)
8033
8034                    One way a user could, I suppose, write "foo" so
8035                    it works is to insert COND_EXPR's for the
8036                    size/shape info so the dangerous stuff isn't
8037                    actually done, as in:
8038
8039                      void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
8040                      {
8041                        ...
8042                      }
8043
8044                    The next problem is that the front end needs to
8045                    be able to tell the back end about the array's
8046                    decl _before_ it tells it about the conditional
8047                    expression to inhibit evaluation of size/shape info,
8048                    as shown above.
8049
8050                    To solve this, the front end needs to be able
8051                    to give the back end the expression to inhibit
8052                    generation of the preevaluation code _after_
8053                    it makes the decl for the adjustable array.
8054
8055                    Until then, the above example using the COND_EXPR
8056                    doesn't pass muster with gcc because the "(a == NULL)"
8057                    part has a reference to "a", which is still
8058                    undefined at that point.
8059
8060                    g77 will therefore use a different mechanism in the
8061                    meantime.  */
8062
8063                 if (!adjustable
8064                     && ((TREE_CODE (low) != INTEGER_CST)
8065                         || (high && TREE_CODE (high) != INTEGER_CST)))
8066                   adjustable = TRUE;
8067
8068 #if 0                           /* Old approach -- see below. */
8069                 if (TREE_CODE (low) != INTEGER_CST)
8070                   low = ffecom_3 (COND_EXPR, integer_type_node,
8071                                   ffecom_adjarray_passed_ (s),
8072                                   low,
8073                                   ffecom_integer_zero_node);
8074
8075                 if (high && TREE_CODE (high) != INTEGER_CST)
8076                   high = ffecom_3 (COND_EXPR, integer_type_node,
8077                                    ffecom_adjarray_passed_ (s),
8078                                    high,
8079                                    ffecom_integer_zero_node);
8080 #endif
8081
8082                 /* ~~~gcc/stor-layout.c (layout_type) should do this,
8083                    probably.  Fixes 950302-1.f.  */
8084
8085                 if (TREE_CODE (low) != INTEGER_CST)
8086                   low = variable_size (low);
8087
8088                 /* ~~~Similarly, this fixes dumb0.f.  The C front end
8089                    does this, which is why dumb0.c would work.  */
8090
8091                 if (high && TREE_CODE (high) != INTEGER_CST)
8092                   high = variable_size (high);
8093
8094                 type
8095                   = build_array_type
8096                     (type,
8097                      build_range_type (ffecom_integer_type_node,
8098                                        low, high));
8099                 type = ffecom_check_size_overflow_ (s, type, TRUE);
8100               }
8101
8102             if (type == error_mark_node)
8103               {
8104                 t = error_mark_node;
8105                 break;
8106               }
8107
8108             if ((ffesymbol_sfdummyparent (s) == NULL)
8109                  || (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
8110               {
8111                 type = build_pointer_type (type);
8112                 addr = TRUE;
8113               }
8114
8115             t = build_decl (PARM_DECL, t, type);
8116 #if BUILT_FOR_270
8117             DECL_ARTIFICIAL (t) = 1;
8118 #endif
8119
8120             /* If this arg is present in every entry point's list of
8121                dummy args, then we're done.  */
8122
8123             if (ffesymbol_numentries (s)
8124                 == (ffecom_num_entrypoints_ + 1))
8125               break;
8126
8127 #if 1
8128
8129             /* If variable_size in stor-layout has been called during
8130                the above, then get_pending_sizes should have the
8131                yet-to-be-evaluated saved expressions pending.
8132                Make the whole lot of them get emitted, conditionally
8133                on whether the array decl ("t" above) is not NULL.  */
8134
8135             {
8136               tree sizes = get_pending_sizes ();
8137               tree tem;
8138
8139               for (tem = sizes;
8140                    tem != old_sizes;
8141                    tem = TREE_CHAIN (tem))
8142                 {
8143                   tree temv = TREE_VALUE (tem);
8144
8145                   if (sizes == tem)
8146                     sizes = temv;
8147                   else
8148                     sizes
8149                       = ffecom_2 (COMPOUND_EXPR,
8150                                   TREE_TYPE (sizes),
8151                                   temv,
8152                                   sizes);
8153                 }
8154
8155               if (sizes != tem)
8156                 {
8157                   sizes
8158                     = ffecom_3 (COND_EXPR,
8159                                 TREE_TYPE (sizes),
8160                                 ffecom_2 (NE_EXPR,
8161                                           integer_type_node,
8162                                           t,
8163                                           null_pointer_node),
8164                                 sizes,
8165                                 convert (TREE_TYPE (sizes),
8166                                          integer_zero_node));
8167                   sizes = ffecom_save_tree (sizes);
8168
8169                   sizes
8170                     = tree_cons (NULL_TREE, sizes, tem);
8171                 }
8172
8173               if (sizes)
8174                 put_pending_sizes (sizes);
8175             }
8176
8177 #else
8178 #if 0
8179             if (adjustable
8180                 && (ffesymbol_numentries (s)
8181                     != ffecom_num_entrypoints_ + 1))
8182               DECL_SOMETHING (t)
8183                 = ffecom_2 (NE_EXPR, integer_type_node,
8184                             t,
8185                             null_pointer_node);
8186 #else
8187 #if 0
8188             if (adjustable
8189                 && (ffesymbol_numentries (s)
8190                     != ffecom_num_entrypoints_ + 1))
8191               {
8192                 ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED);
8193                 ffebad_here (0, ffesymbol_where_line (s),
8194                              ffesymbol_where_column (s));
8195                 ffebad_string (ffesymbol_text (s));
8196                 ffebad_finish ();
8197               }
8198 #endif
8199 #endif
8200 #endif
8201           }
8202           break;
8203
8204         case FFEINFO_whereCOMMON:
8205           {
8206             ffesymbol cs;
8207             ffeglobal cg;
8208             tree ct;
8209             ffestorag st = ffesymbol_storage (s);
8210             tree type;
8211             int yes;
8212
8213             cs = ffesymbol_common (s);  /* The COMMON area itself.  */
8214             if (st != NULL)     /* Else not laid out. */
8215               {
8216                 ffecom_transform_common_ (cs);
8217                 st = ffesymbol_storage (s);
8218               }
8219
8220             yes = suspend_momentary ();
8221
8222             type = ffecom_type_localvar_ (s, bt, kt);
8223
8224             cg = ffesymbol_global (cs); /* The global COMMON info.  */
8225             if ((cg == NULL)
8226                 || (ffeglobal_type (cg) != FFEGLOBAL_typeCOMMON))
8227               ct = NULL_TREE;
8228             else
8229               ct = ffeglobal_hook (cg); /* The common area's tree.  */
8230
8231             if ((ct == NULL_TREE)
8232                 || (st == NULL)
8233                 || (type == error_mark_node))
8234               t = error_mark_node;
8235             else
8236               {
8237                 ffetargetOffset offset;
8238                 ffestorag cst;
8239
8240                 cst = ffestorag_parent (st);
8241                 assert (cst == ffesymbol_storage (cs));
8242
8243                 offset = ffestorag_modulo (cst)
8244                   + ffestorag_offset (st)
8245                   - ffestorag_offset (cst);
8246
8247                 ffecom_debug_kludge_ (ct, "COMMON", s, type, offset);
8248
8249                 /* (t_type *) (((char *) &ct) + offset) */
8250
8251                 t = convert (string_type_node,  /* (char *) */
8252                              ffecom_1 (ADDR_EXPR,
8253                                        build_pointer_type (TREE_TYPE (ct)),
8254                                        ct));
8255                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
8256                               t,
8257                               build_int_2 (offset, 0));
8258                 t = convert (build_pointer_type (type),
8259                              t);
8260                 TREE_CONSTANT (t) = 1;
8261
8262                 addr = TRUE;
8263               }
8264
8265             resume_momentary (yes);
8266           }
8267           break;
8268
8269         case FFEINFO_whereIMMEDIATE:
8270         case FFEINFO_whereGLOBAL:
8271         case FFEINFO_whereFLEETING:
8272         case FFEINFO_whereFLEETING_CADDR:
8273         case FFEINFO_whereFLEETING_IADDR:
8274         case FFEINFO_whereINTRINSIC:
8275         case FFEINFO_whereCONSTANT_SUBOBJECT:
8276         default:
8277           assert ("ENTITY where unheard of" == NULL);
8278           /* Fall through. */
8279         case FFEINFO_whereANY:
8280           t = error_mark_node;
8281           break;
8282         }
8283       break;
8284
8285     case FFEINFO_kindFUNCTION:
8286       switch (ffeinfo_where (ffesymbol_info (s)))
8287         {
8288         case FFEINFO_whereLOCAL:        /* Me. */
8289           assert (!ffecom_transform_only_dummies_);
8290           t = current_function_decl;
8291           break;
8292
8293         case FFEINFO_whereGLOBAL:
8294           assert (!ffecom_transform_only_dummies_);
8295
8296           if (((g = ffesymbol_global (s)) != NULL)
8297               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8298                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8299               && (ffeglobal_hook (g) != NULL_TREE)
8300               && ffe_is_globals ())
8301             {
8302               t = ffeglobal_hook (g);
8303               break;
8304             }
8305
8306           if (ffesymbol_is_f2c (s)
8307               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8308             t = ffecom_tree_fun_type[bt][kt];
8309           else
8310             t = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
8311
8312           t = build_decl (FUNCTION_DECL,
8313                           ffecom_get_external_identifier_ (s),
8314                           t);
8315           DECL_EXTERNAL (t) = 1;
8316           TREE_PUBLIC (t) = 1;
8317
8318           t = start_decl (t, FALSE);
8319           finish_decl (t, NULL_TREE, FALSE);
8320
8321           if ((g != NULL)
8322               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8323                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8324             ffeglobal_set_hook (g, t);
8325
8326           ffecom_save_tree_forever (t);
8327
8328           break;
8329
8330         case FFEINFO_whereDUMMY:
8331           assert (ffecom_transform_only_dummies_);
8332
8333           if (ffesymbol_is_f2c (s)
8334               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8335             t = ffecom_tree_ptr_to_fun_type[bt][kt];
8336           else
8337             t = build_pointer_type
8338               (build_function_type (ffecom_tree_type[bt][kt], NULL_TREE));
8339
8340           t = build_decl (PARM_DECL,
8341                           ffecom_get_identifier_ (ffesymbol_text (s)),
8342                           t);
8343 #if BUILT_FOR_270
8344           DECL_ARTIFICIAL (t) = 1;
8345 #endif
8346           addr = TRUE;
8347           break;
8348
8349         case FFEINFO_whereCONSTANT:     /* Statement function. */
8350           assert (!ffecom_transform_only_dummies_);
8351           t = ffecom_gen_sfuncdef_ (s, bt, kt);
8352           break;
8353
8354         case FFEINFO_whereINTRINSIC:
8355           assert (!ffecom_transform_only_dummies_);
8356           break;                /* Let actual references generate their
8357                                    decls. */
8358
8359         default:
8360           assert ("FUNCTION where unheard of" == NULL);
8361           /* Fall through. */
8362         case FFEINFO_whereANY:
8363           t = error_mark_node;
8364           break;
8365         }
8366       break;
8367
8368     case FFEINFO_kindSUBROUTINE:
8369       switch (ffeinfo_where (ffesymbol_info (s)))
8370         {
8371         case FFEINFO_whereLOCAL:        /* Me. */
8372           assert (!ffecom_transform_only_dummies_);
8373           t = current_function_decl;
8374           break;
8375
8376         case FFEINFO_whereGLOBAL:
8377           assert (!ffecom_transform_only_dummies_);
8378
8379           if (((g = ffesymbol_global (s)) != NULL)
8380               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8381                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8382               && (ffeglobal_hook (g) != NULL_TREE)
8383               && ffe_is_globals ())
8384             {
8385               t = ffeglobal_hook (g);
8386               break;
8387             }
8388
8389           t = build_decl (FUNCTION_DECL,
8390                           ffecom_get_external_identifier_ (s),
8391                           ffecom_tree_subr_type);
8392           DECL_EXTERNAL (t) = 1;
8393           TREE_PUBLIC (t) = 1;
8394
8395           t = start_decl (t, FALSE);
8396           finish_decl (t, NULL_TREE, FALSE);
8397
8398           if ((g != NULL)
8399               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8400                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8401             ffeglobal_set_hook (g, t);
8402
8403           ffecom_save_tree_forever (t);
8404
8405           break;
8406
8407         case FFEINFO_whereDUMMY:
8408           assert (ffecom_transform_only_dummies_);
8409
8410           t = build_decl (PARM_DECL,
8411                           ffecom_get_identifier_ (ffesymbol_text (s)),
8412                           ffecom_tree_ptr_to_subr_type);
8413 #if BUILT_FOR_270
8414           DECL_ARTIFICIAL (t) = 1;
8415 #endif
8416           addr = TRUE;
8417           break;
8418
8419         case FFEINFO_whereINTRINSIC:
8420           assert (!ffecom_transform_only_dummies_);
8421           break;                /* Let actual references generate their
8422                                    decls. */
8423
8424         default:
8425           assert ("SUBROUTINE where unheard of" == NULL);
8426           /* Fall through. */
8427         case FFEINFO_whereANY:
8428           t = error_mark_node;
8429           break;
8430         }
8431       break;
8432
8433     case FFEINFO_kindPROGRAM:
8434       switch (ffeinfo_where (ffesymbol_info (s)))
8435         {
8436         case FFEINFO_whereLOCAL:        /* Me. */
8437           assert (!ffecom_transform_only_dummies_);
8438           t = current_function_decl;
8439           break;
8440
8441         case FFEINFO_whereCOMMON:
8442         case FFEINFO_whereDUMMY:
8443         case FFEINFO_whereGLOBAL:
8444         case FFEINFO_whereRESULT:
8445         case FFEINFO_whereFLEETING:
8446         case FFEINFO_whereFLEETING_CADDR:
8447         case FFEINFO_whereFLEETING_IADDR:
8448         case FFEINFO_whereIMMEDIATE:
8449         case FFEINFO_whereINTRINSIC:
8450         case FFEINFO_whereCONSTANT:
8451         case FFEINFO_whereCONSTANT_SUBOBJECT:
8452         default:
8453           assert ("PROGRAM where unheard of" == NULL);
8454           /* Fall through. */
8455         case FFEINFO_whereANY:
8456           t = error_mark_node;
8457           break;
8458         }
8459       break;
8460
8461     case FFEINFO_kindBLOCKDATA:
8462       switch (ffeinfo_where (ffesymbol_info (s)))
8463         {
8464         case FFEINFO_whereLOCAL:        /* Me. */
8465           assert (!ffecom_transform_only_dummies_);
8466           t = current_function_decl;
8467           break;
8468
8469         case FFEINFO_whereGLOBAL:
8470           assert (!ffecom_transform_only_dummies_);
8471
8472           t = build_decl (FUNCTION_DECL,
8473                           ffecom_get_external_identifier_ (s),
8474                           ffecom_tree_blockdata_type);
8475           DECL_EXTERNAL (t) = 1;
8476           TREE_PUBLIC (t) = 1;
8477
8478           t = start_decl (t, FALSE);
8479           finish_decl (t, NULL_TREE, FALSE);
8480
8481           ffecom_save_tree_forever (t);
8482
8483           break;
8484
8485         case FFEINFO_whereCOMMON:
8486         case FFEINFO_whereDUMMY:
8487         case FFEINFO_whereRESULT:
8488         case FFEINFO_whereFLEETING:
8489         case FFEINFO_whereFLEETING_CADDR:
8490         case FFEINFO_whereFLEETING_IADDR:
8491         case FFEINFO_whereIMMEDIATE:
8492         case FFEINFO_whereINTRINSIC:
8493         case FFEINFO_whereCONSTANT:
8494         case FFEINFO_whereCONSTANT_SUBOBJECT:
8495         default:
8496           assert ("BLOCKDATA where unheard of" == NULL);
8497           /* Fall through. */
8498         case FFEINFO_whereANY:
8499           t = error_mark_node;
8500           break;
8501         }
8502       break;
8503
8504     case FFEINFO_kindCOMMON:
8505       switch (ffeinfo_where (ffesymbol_info (s)))
8506         {
8507         case FFEINFO_whereLOCAL:
8508           assert (!ffecom_transform_only_dummies_);
8509           ffecom_transform_common_ (s);
8510           break;
8511
8512         case FFEINFO_whereNONE:
8513         case FFEINFO_whereCOMMON:
8514         case FFEINFO_whereDUMMY:
8515         case FFEINFO_whereGLOBAL:
8516         case FFEINFO_whereRESULT:
8517         case FFEINFO_whereFLEETING:
8518         case FFEINFO_whereFLEETING_CADDR:
8519         case FFEINFO_whereFLEETING_IADDR:
8520         case FFEINFO_whereIMMEDIATE:
8521         case FFEINFO_whereINTRINSIC:
8522         case FFEINFO_whereCONSTANT:
8523         case FFEINFO_whereCONSTANT_SUBOBJECT:
8524         default:
8525           assert ("COMMON where unheard of" == NULL);
8526           /* Fall through. */
8527         case FFEINFO_whereANY:
8528           t = error_mark_node;
8529           break;
8530         }
8531       break;
8532
8533     case FFEINFO_kindCONSTRUCT:
8534       switch (ffeinfo_where (ffesymbol_info (s)))
8535         {
8536         case FFEINFO_whereLOCAL:
8537           assert (!ffecom_transform_only_dummies_);
8538           break;
8539
8540         case FFEINFO_whereNONE:
8541         case FFEINFO_whereCOMMON:
8542         case FFEINFO_whereDUMMY:
8543         case FFEINFO_whereGLOBAL:
8544         case FFEINFO_whereRESULT:
8545         case FFEINFO_whereFLEETING:
8546         case FFEINFO_whereFLEETING_CADDR:
8547         case FFEINFO_whereFLEETING_IADDR:
8548         case FFEINFO_whereIMMEDIATE:
8549         case FFEINFO_whereINTRINSIC:
8550         case FFEINFO_whereCONSTANT:
8551         case FFEINFO_whereCONSTANT_SUBOBJECT:
8552         default:
8553           assert ("CONSTRUCT where unheard of" == NULL);
8554           /* Fall through. */
8555         case FFEINFO_whereANY:
8556           t = error_mark_node;
8557           break;
8558         }
8559       break;
8560
8561     case FFEINFO_kindNAMELIST:
8562       switch (ffeinfo_where (ffesymbol_info (s)))
8563         {
8564         case FFEINFO_whereLOCAL:
8565           assert (!ffecom_transform_only_dummies_);
8566           t = ffecom_transform_namelist_ (s);
8567           break;
8568
8569         case FFEINFO_whereNONE:
8570         case FFEINFO_whereCOMMON:
8571         case FFEINFO_whereDUMMY:
8572         case FFEINFO_whereGLOBAL:
8573         case FFEINFO_whereRESULT:
8574         case FFEINFO_whereFLEETING:
8575         case FFEINFO_whereFLEETING_CADDR:
8576         case FFEINFO_whereFLEETING_IADDR:
8577         case FFEINFO_whereIMMEDIATE:
8578         case FFEINFO_whereINTRINSIC:
8579         case FFEINFO_whereCONSTANT:
8580         case FFEINFO_whereCONSTANT_SUBOBJECT:
8581         default:
8582           assert ("NAMELIST where unheard of" == NULL);
8583           /* Fall through. */
8584         case FFEINFO_whereANY:
8585           t = error_mark_node;
8586           break;
8587         }
8588       break;
8589
8590     default:
8591       assert ("kind unheard of" == NULL);
8592       /* Fall through. */
8593     case FFEINFO_kindANY:
8594       t = error_mark_node;
8595       break;
8596     }
8597
8598   ffesymbol_hook (s).decl_tree = t;
8599   ffesymbol_hook (s).length_tree = tlen;
8600   ffesymbol_hook (s).addr = addr;
8601
8602   lineno = old_lineno;
8603   input_filename = old_input_filename;
8604
8605   return s;
8606 }
8607
8608 #endif
8609 /* Transform into ASSIGNable symbol.
8610
8611    Symbol has already been transformed, but for whatever reason, the
8612    resulting decl_tree has been deemed not usable for an ASSIGN target.
8613    (E.g. it isn't wide enough to hold a pointer.)  So, here we invent
8614    another local symbol of type void * and stuff that in the assign_tree
8615    argument.  The F77/F90 standards allow this implementation.  */
8616
8617 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8618 static ffesymbol
8619 ffecom_sym_transform_assign_ (ffesymbol s)
8620 {
8621   tree t;                       /* Transformed thingy. */
8622   int yes;
8623   int old_lineno = lineno;
8624   const char *old_input_filename = input_filename;
8625
8626   if (ffesymbol_sfdummyparent (s) == NULL)
8627     {
8628       input_filename = ffesymbol_where_filename (s);
8629       lineno = ffesymbol_where_filelinenum (s);
8630     }
8631   else
8632     {
8633       ffesymbol sf = ffesymbol_sfdummyparent (s);
8634
8635       input_filename = ffesymbol_where_filename (sf);
8636       lineno = ffesymbol_where_filelinenum (sf);
8637     }
8638
8639   assert (!ffecom_transform_only_dummies_);
8640
8641   yes = suspend_momentary ();
8642
8643   t = build_decl (VAR_DECL,
8644                   ffecom_get_invented_identifier ("__g77_ASSIGN_%s",
8645                                                    ffesymbol_text (s)),
8646                   TREE_TYPE (null_pointer_node));
8647
8648   switch (ffesymbol_where (s))
8649     {
8650     case FFEINFO_whereLOCAL:
8651       /* Unlike for regular vars, SAVE status is easy to determine for
8652          ASSIGNed vars, since there's no initialization, there's no
8653          effective storage association (so "SAVE J" does not apply to
8654          K even given "EQUIVALENCE (J,K)"), there's no size issue
8655          to worry about, etc.  */
8656       if ((ffesymbol_is_save (s) || ffe_is_saveall ())
8657           && (ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8658           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA))
8659         TREE_STATIC (t) = 1;    /* SAVEd in proc, make static. */
8660       else
8661         TREE_STATIC (t) = 0;    /* No need to make static. */
8662       break;
8663
8664     case FFEINFO_whereCOMMON:
8665       TREE_STATIC (t) = 1;      /* Assume COMMONs always SAVEd. */
8666       break;
8667
8668     case FFEINFO_whereDUMMY:
8669       /* Note that twinning a DUMMY means the caller won't see
8670          the ASSIGNed value.  But both F77 and F90 allow implementations
8671          to do this, i.e. disallow Fortran code that would try and
8672          take advantage of actually putting a label into a variable
8673          via a dummy argument (or any other storage association, for
8674          that matter).  */
8675       TREE_STATIC (t) = 0;
8676       break;
8677
8678     default:
8679       TREE_STATIC (t) = 0;
8680       break;
8681     }
8682
8683   t = start_decl (t, FALSE);
8684   finish_decl (t, NULL_TREE, FALSE);
8685
8686   resume_momentary (yes);
8687
8688   ffesymbol_hook (s).assign_tree = t;
8689
8690   lineno = old_lineno;
8691   input_filename = old_input_filename;
8692
8693   return s;
8694 }
8695
8696 #endif
8697 /* Implement COMMON area in back end.
8698
8699    Because COMMON-based variables can be referenced in the dimension
8700    expressions of dummy (adjustable) arrays, and because dummies
8701    (in the gcc back end) need to be put in the outer binding level
8702    of a function (which has two binding levels, the outer holding
8703    the dummies and the inner holding the other vars), special care
8704    must be taken to handle COMMON areas.
8705
8706    The current strategy is basically to always tell the back end about
8707    the COMMON area as a top-level external reference to just a block
8708    of storage of the master type of that area (e.g. integer, real,
8709    character, whatever -- not a structure).  As a distinct action,
8710    if initial values are provided, tell the back end about the area
8711    as a top-level non-external (initialized) area and remember not to
8712    allow further initialization or expansion of the area.  Meanwhile,
8713    if no initialization happens at all, tell the back end about
8714    the largest size we've seen declared so the space does get reserved.
8715    (This function doesn't handle all that stuff, but it does some
8716    of the important things.)
8717
8718    Meanwhile, for COMMON variables themselves, just keep creating
8719    references like *((float *) (&common_area + offset)) each time
8720    we reference the variable.  In other words, don't make a VAR_DECL
8721    or any kind of component reference (like we used to do before 0.4),
8722    though we might do that as well just for debugging purposes (and
8723    stuff the rtl with the appropriate offset expression).  */
8724
8725 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8726 static void
8727 ffecom_transform_common_ (ffesymbol s)
8728 {
8729   ffestorag st = ffesymbol_storage (s);
8730   ffeglobal g = ffesymbol_global (s);
8731   tree cbt;
8732   tree cbtype;
8733   tree init;
8734   tree high;
8735   bool is_init = ffestorag_is_init (st);
8736
8737   assert (st != NULL);
8738
8739   if ((g == NULL)
8740       || (ffeglobal_type (g) != FFEGLOBAL_typeCOMMON))
8741     return;
8742
8743   /* First update the size of the area in global terms.  */
8744
8745   ffeglobal_size_common (s, ffestorag_size (st));
8746
8747   if (!ffeglobal_common_init (g))
8748     is_init = FALSE;    /* No explicit init, don't let erroneous joins init. */
8749
8750   cbt = ffeglobal_hook (g);
8751
8752   /* If we already have declared this common block for a previous program
8753      unit, and either we already initialized it or we don't have new
8754      initialization for it, just return what we have without changing it.  */
8755
8756   if ((cbt != NULL_TREE)
8757       && (!is_init
8758           || !DECL_EXTERNAL (cbt)))
8759     {
8760       if (st->hook == NULL) ffestorag_set_hook (st, cbt);
8761       return;
8762     }
8763
8764   /* Process inits.  */
8765
8766   if (is_init)
8767     {
8768       if (ffestorag_init (st) != NULL)
8769         {
8770           ffebld sexp;
8771
8772           /* Set the padding for the expression, so ffecom_expr
8773              knows to insert that many zeros.  */
8774           switch (ffebld_op (sexp = ffestorag_init (st)))
8775             {
8776             case FFEBLD_opCONTER:
8777               ffebld_conter_set_pad (sexp, ffestorag_modulo (st));
8778               break;
8779
8780             case FFEBLD_opARRTER:
8781               ffebld_arrter_set_pad (sexp, ffestorag_modulo (st));
8782               break;
8783
8784             case FFEBLD_opACCTER:
8785               ffebld_accter_set_pad (sexp, ffestorag_modulo (st));
8786               break;
8787
8788             default:
8789               assert ("bad op for cmn init (pad)" == NULL);
8790               break;
8791             }
8792
8793           init = ffecom_expr (sexp);
8794           if (init == error_mark_node)
8795             {                   /* Hopefully the back end complained! */
8796               init = NULL_TREE;
8797               if (cbt != NULL_TREE)
8798                 return;
8799             }
8800         }
8801       else
8802         init = error_mark_node;
8803     }
8804   else
8805     init = NULL_TREE;
8806
8807   /* cbtype must be permanently allocated!  */
8808
8809   /* Allocate the MAX of the areas so far, seen filewide.  */
8810   high = build_int_2 ((ffeglobal_common_size (g)
8811                        + ffeglobal_common_pad (g)) - 1, 0);
8812   TREE_TYPE (high) = ffecom_integer_type_node;
8813
8814   if (init)
8815     cbtype = build_array_type (char_type_node,
8816                                build_range_type (integer_type_node,
8817                                                  integer_zero_node,
8818                                                  high));
8819   else
8820     cbtype = build_array_type (char_type_node, NULL_TREE);
8821
8822   if (cbt == NULL_TREE)
8823     {
8824       cbt
8825         = build_decl (VAR_DECL,
8826                       ffecom_get_external_identifier_ (s),
8827                       cbtype);
8828       TREE_STATIC (cbt) = 1;
8829       TREE_PUBLIC (cbt) = 1;
8830     }
8831   else
8832     {
8833       assert (is_init);
8834       TREE_TYPE (cbt) = cbtype;
8835     }
8836   DECL_EXTERNAL (cbt) = init ? 0 : 1;
8837   DECL_INITIAL (cbt) = init ? error_mark_node : NULL_TREE;
8838
8839   cbt = start_decl (cbt, TRUE);
8840   if (ffeglobal_hook (g) != NULL)
8841     assert (cbt == ffeglobal_hook (g));
8842
8843   assert (!init || !DECL_EXTERNAL (cbt));
8844
8845   /* Make sure that any type can live in COMMON and be referenced
8846      without getting a bus error.  We could pick the most restrictive
8847      alignment of all entities actually placed in the COMMON, but
8848      this seems easy enough.  */
8849
8850   DECL_ALIGN (cbt) = BIGGEST_ALIGNMENT;
8851   DECL_USER_ALIGN (cbt) = 0;
8852
8853   if (is_init && (ffestorag_init (st) == NULL))
8854     init = ffecom_init_zero_ (cbt);
8855
8856   finish_decl (cbt, init, TRUE);
8857
8858   if (is_init)
8859     ffestorag_set_init (st, ffebld_new_any ());
8860
8861   if (init)
8862     {
8863       assert (DECL_SIZE_UNIT (cbt) != NULL_TREE);
8864       assert (TREE_CODE (DECL_SIZE_UNIT (cbt)) == INTEGER_CST);
8865       assert (0 == compare_tree_int (DECL_SIZE_UNIT (cbt),
8866                                      (ffeglobal_common_size (g)
8867                                       + ffeglobal_common_pad (g))));
8868     }
8869
8870   ffeglobal_set_hook (g, cbt);
8871
8872   ffestorag_set_hook (st, cbt);
8873
8874   ffecom_save_tree_forever (cbt);
8875 }
8876
8877 #endif
8878 /* Make master area for local EQUIVALENCE.  */
8879
8880 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8881 static void
8882 ffecom_transform_equiv_ (ffestorag eqst)
8883 {
8884   tree eqt;
8885   tree eqtype;
8886   tree init;
8887   tree high;
8888   bool is_init = ffestorag_is_init (eqst);
8889   int yes;
8890
8891   assert (eqst != NULL);
8892
8893   eqt = ffestorag_hook (eqst);
8894
8895   if (eqt != NULL_TREE)
8896     return;
8897
8898   /* Process inits.  */
8899
8900   if (is_init)
8901     {
8902       if (ffestorag_init (eqst) != NULL)
8903         {
8904           ffebld sexp;
8905
8906           /* Set the padding for the expression, so ffecom_expr
8907              knows to insert that many zeros.  */
8908           switch (ffebld_op (sexp = ffestorag_init (eqst)))
8909             {
8910             case FFEBLD_opCONTER:
8911               ffebld_conter_set_pad (sexp, ffestorag_modulo (eqst));
8912               break;
8913
8914             case FFEBLD_opARRTER:
8915               ffebld_arrter_set_pad (sexp, ffestorag_modulo (eqst));
8916               break;
8917
8918             case FFEBLD_opACCTER:
8919               ffebld_accter_set_pad (sexp, ffestorag_modulo (eqst));
8920               break;
8921
8922             default:
8923               assert ("bad op for eqv init (pad)" == NULL);
8924               break;
8925             }
8926
8927           init = ffecom_expr (sexp);
8928           if (init == error_mark_node)
8929             init = NULL_TREE;   /* Hopefully the back end complained! */
8930         }
8931       else
8932         init = error_mark_node;
8933     }
8934   else if (ffe_is_init_local_zero ())
8935     init = error_mark_node;
8936   else
8937     init = NULL_TREE;
8938
8939   ffecom_member_namelisted_ = FALSE;
8940   ffestorag_drive (ffestorag_list_equivs (eqst),
8941                    &ffecom_member_phase1_,
8942                    eqst);
8943
8944   yes = suspend_momentary ();
8945
8946   high = build_int_2 ((ffestorag_size (eqst)
8947                        + ffestorag_modulo (eqst)) - 1, 0);
8948   TREE_TYPE (high) = ffecom_integer_type_node;
8949
8950   eqtype = build_array_type (char_type_node,
8951                              build_range_type (ffecom_integer_type_node,
8952                                                ffecom_integer_zero_node,
8953                                                high));
8954
8955   eqt = build_decl (VAR_DECL,
8956                     ffecom_get_invented_identifier ("__g77_equiv_%s",
8957                                                     ffesymbol_text
8958                                                     (ffestorag_symbol (eqst))),
8959                     eqtype);
8960   DECL_EXTERNAL (eqt) = 0;
8961   if (is_init
8962       || ffecom_member_namelisted_
8963 #ifdef FFECOM_sizeMAXSTACKITEM
8964       || (ffestorag_size (eqst) > FFECOM_sizeMAXSTACKITEM)
8965 #endif
8966       || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8967           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
8968           && (ffestorag_is_save (eqst) || ffe_is_saveall ())))
8969     TREE_STATIC (eqt) = 1;
8970   else
8971     TREE_STATIC (eqt) = 0;
8972   TREE_PUBLIC (eqt) = 0;
8973   TREE_ADDRESSABLE (eqt) = 1;  /* Ensure non-register allocation */
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   DECL_USER_ALIGN (eqt) = 0;
8989
8990   if ((!is_init && ffe_is_init_local_zero ())
8991       || (is_init && (ffestorag_init (eqst) == NULL)))
8992     init = ffecom_init_zero_ (eqt);
8993
8994   finish_decl (eqt, init, FALSE);
8995
8996   if (is_init)
8997     ffestorag_set_init (eqst, ffebld_new_any ());
8998
8999   {
9000     assert (TREE_CODE (DECL_SIZE_UNIT (eqt)) == INTEGER_CST);
9001     assert (0 == compare_tree_int (DECL_SIZE_UNIT (eqt),
9002                                    (ffestorag_size (eqst)
9003                                     + ffestorag_modulo (eqst))));
9004   }
9005
9006   ffestorag_set_hook (eqst, eqt);
9007
9008   ffestorag_drive (ffestorag_list_equivs (eqst),
9009                    &ffecom_member_phase2_,
9010                    eqst);
9011
9012   resume_momentary (yes);
9013 }
9014
9015 #endif
9016 /* Implement NAMELIST in back end.  See f2c/format.c for more info.  */
9017
9018 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9019 static tree
9020 ffecom_transform_namelist_ (ffesymbol s)
9021 {
9022   tree nmlt;
9023   tree nmltype = ffecom_type_namelist_ ();
9024   tree nmlinits;
9025   tree nameinit;
9026   tree varsinit;
9027   tree nvarsinit;
9028   tree field;
9029   tree high;
9030   int yes;
9031   int i;
9032   static int mynumber = 0;
9033
9034   yes = suspend_momentary ();
9035
9036   nmlt = build_decl (VAR_DECL,
9037                      ffecom_get_invented_identifier ("__g77_namelist_%d",
9038                                                      mynumber++),
9039                      nmltype);
9040   TREE_STATIC (nmlt) = 1;
9041   DECL_INITIAL (nmlt) = error_mark_node;
9042
9043   nmlt = start_decl (nmlt, FALSE);
9044
9045   /* Process inits.  */
9046
9047   i = strlen (ffesymbol_text (s));
9048
9049   high = build_int_2 (i, 0);
9050   TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
9051
9052   nameinit = ffecom_build_f2c_string_ (i + 1,
9053                                        ffesymbol_text (s));
9054   TREE_TYPE (nameinit)
9055     = build_type_variant
9056     (build_array_type
9057      (char_type_node,
9058       build_range_type (ffecom_f2c_ftnlen_type_node,
9059                         ffecom_f2c_ftnlen_one_node,
9060                         high)),
9061      1, 0);
9062   TREE_CONSTANT (nameinit) = 1;
9063   TREE_STATIC (nameinit) = 1;
9064   nameinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (nameinit)),
9065                        nameinit);
9066
9067   varsinit = ffecom_vardesc_array_ (s);
9068   varsinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (varsinit)),
9069                        varsinit);
9070   TREE_CONSTANT (varsinit) = 1;
9071   TREE_STATIC (varsinit) = 1;
9072
9073   {
9074     ffebld b;
9075
9076     for (i = 0, b = ffesymbol_namelist (s); b != NULL; b = ffebld_trail (b))
9077       ++i;
9078   }
9079   nvarsinit = build_int_2 (i, 0);
9080   TREE_TYPE (nvarsinit) = integer_type_node;
9081   TREE_CONSTANT (nvarsinit) = 1;
9082   TREE_STATIC (nvarsinit) = 1;
9083
9084   nmlinits = build_tree_list ((field = TYPE_FIELDS (nmltype)), nameinit);
9085   TREE_CHAIN (nmlinits) = build_tree_list ((field = TREE_CHAIN (field)),
9086                                            varsinit);
9087   TREE_CHAIN (TREE_CHAIN (nmlinits))
9088     = build_tree_list ((field = TREE_CHAIN (field)), nvarsinit);
9089
9090   nmlinits = build (CONSTRUCTOR, nmltype, NULL_TREE, nmlinits);
9091   TREE_CONSTANT (nmlinits) = 1;
9092   TREE_STATIC (nmlinits) = 1;
9093
9094   finish_decl (nmlt, nmlinits, FALSE);
9095
9096   nmlt = ffecom_1 (ADDR_EXPR, build_pointer_type (nmltype), nmlt);
9097
9098   resume_momentary (yes);
9099
9100   return nmlt;
9101 }
9102
9103 #endif
9104
9105 /* A subroutine of ffecom_tree_canonize_ref_.  The incoming tree is
9106    analyzed on the assumption it is calculating a pointer to be
9107    indirected through.  It must return the proper decl and offset,
9108    taking into account different units of measurements for offsets.  */
9109
9110 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9111 static void
9112 ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
9113                            tree t)
9114 {
9115   switch (TREE_CODE (t))
9116     {
9117     case NOP_EXPR:
9118     case CONVERT_EXPR:
9119     case NON_LVALUE_EXPR:
9120       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
9121       break;
9122
9123     case PLUS_EXPR:
9124       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
9125       if ((*decl == NULL_TREE)
9126           || (*decl == error_mark_node))
9127         break;
9128
9129       if (TREE_CODE (TREE_OPERAND (t, 1)) == INTEGER_CST)
9130         {
9131           /* An offset into COMMON.  */
9132           *offset = fold (build (PLUS_EXPR, TREE_TYPE (*offset),
9133                                  *offset, TREE_OPERAND (t, 1)));
9134           /* Convert offset (presumably in bytes) into canonical units
9135              (presumably bits).  */
9136           *offset = size_binop (MULT_EXPR,
9137                                 convert (bitsizetype, *offset),
9138                                 TYPE_SIZE (TREE_TYPE (TREE_TYPE (t))));
9139           break;
9140         }
9141       /* Not a COMMON reference, so an unrecognized pattern.  */
9142       *decl = error_mark_node;
9143       break;
9144
9145     case PARM_DECL:
9146       *decl = t;
9147       *offset = bitsize_zero_node;
9148       break;
9149
9150     case ADDR_EXPR:
9151       if (TREE_CODE (TREE_OPERAND (t, 0)) == VAR_DECL)
9152         {
9153           /* A reference to COMMON.  */
9154           *decl = TREE_OPERAND (t, 0);
9155           *offset = bitsize_zero_node;
9156           break;
9157         }
9158       /* Fall through.  */
9159     default:
9160       /* Not a COMMON reference, so an unrecognized pattern.  */
9161       *decl = error_mark_node;
9162       break;
9163     }
9164 }
9165 #endif
9166
9167 /* Given a tree that is possibly intended for use as an lvalue, return
9168    information representing a canonical view of that tree as a decl, an
9169    offset into that decl, and a size for the lvalue.
9170
9171    If there's no applicable decl, NULL_TREE is returned for the decl,
9172    and the other fields are left undefined.
9173
9174    If the tree doesn't fit the recognizable forms, an ERROR_MARK node
9175    is returned for the decl, and the other fields are left undefined.
9176
9177    Otherwise, the decl returned currently is either a VAR_DECL or a
9178    PARM_DECL.
9179
9180    The offset returned is always valid, but of course not necessarily
9181    a constant, and not necessarily converted into the appropriate
9182    type, leaving that up to the caller (so as to avoid that overhead
9183    if the decls being looked at are different anyway).
9184
9185    If the size cannot be determined (e.g. an adjustable array),
9186    an ERROR_MARK node is returned for the size.  Otherwise, the
9187    size returned is valid, not necessarily a constant, and not
9188    necessarily converted into the appropriate type as with the
9189    offset.
9190
9191    Note that the offset and size expressions are expressed in the
9192    base storage units (usually bits) rather than in the units of
9193    the type of the decl, because two decls with different types
9194    might overlap but with apparently non-overlapping array offsets,
9195    whereas converting the array offsets to consistant offsets will
9196    reveal the overlap.  */
9197
9198 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9199 static void
9200 ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
9201                            tree *size, tree t)
9202 {
9203   /* The default path is to report a nonexistant decl.  */
9204   *decl = NULL_TREE;
9205
9206   if (t == NULL_TREE)
9207     return;
9208
9209   switch (TREE_CODE (t))
9210     {
9211     case ERROR_MARK:
9212     case IDENTIFIER_NODE:
9213     case INTEGER_CST:
9214     case REAL_CST:
9215     case COMPLEX_CST:
9216     case STRING_CST:
9217     case CONST_DECL:
9218     case PLUS_EXPR:
9219     case MINUS_EXPR:
9220     case MULT_EXPR:
9221     case TRUNC_DIV_EXPR:
9222     case CEIL_DIV_EXPR:
9223     case FLOOR_DIV_EXPR:
9224     case ROUND_DIV_EXPR:
9225     case TRUNC_MOD_EXPR:
9226     case CEIL_MOD_EXPR:
9227     case FLOOR_MOD_EXPR:
9228     case ROUND_MOD_EXPR:
9229     case RDIV_EXPR:
9230     case EXACT_DIV_EXPR:
9231     case FIX_TRUNC_EXPR:
9232     case FIX_CEIL_EXPR:
9233     case FIX_FLOOR_EXPR:
9234     case FIX_ROUND_EXPR:
9235     case FLOAT_EXPR:
9236     case EXPON_EXPR:
9237     case NEGATE_EXPR:
9238     case MIN_EXPR:
9239     case MAX_EXPR:
9240     case ABS_EXPR:
9241     case FFS_EXPR:
9242     case LSHIFT_EXPR:
9243     case RSHIFT_EXPR:
9244     case LROTATE_EXPR:
9245     case RROTATE_EXPR:
9246     case BIT_IOR_EXPR:
9247     case BIT_XOR_EXPR:
9248     case BIT_AND_EXPR:
9249     case BIT_ANDTC_EXPR:
9250     case BIT_NOT_EXPR:
9251     case TRUTH_ANDIF_EXPR:
9252     case TRUTH_ORIF_EXPR:
9253     case TRUTH_AND_EXPR:
9254     case TRUTH_OR_EXPR:
9255     case TRUTH_XOR_EXPR:
9256     case TRUTH_NOT_EXPR:
9257     case LT_EXPR:
9258     case LE_EXPR:
9259     case GT_EXPR:
9260     case GE_EXPR:
9261     case EQ_EXPR:
9262     case NE_EXPR:
9263     case COMPLEX_EXPR:
9264     case CONJ_EXPR:
9265     case REALPART_EXPR:
9266     case IMAGPART_EXPR:
9267     case LABEL_EXPR:
9268     case COMPONENT_REF:
9269     case COMPOUND_EXPR:
9270     case ADDR_EXPR:
9271       return;
9272
9273     case VAR_DECL:
9274     case PARM_DECL:
9275       *decl = t;
9276       *offset = bitsize_zero_node;
9277       *size = TYPE_SIZE (TREE_TYPE (t));
9278       return;
9279
9280     case ARRAY_REF:
9281       {
9282         tree array = TREE_OPERAND (t, 0);
9283         tree element = TREE_OPERAND (t, 1);
9284         tree init_offset;
9285
9286         if ((array == NULL_TREE)
9287             || (element == NULL_TREE))
9288           {
9289             *decl = error_mark_node;
9290             return;
9291           }
9292
9293         ffecom_tree_canonize_ref_ (decl, &init_offset, size,
9294                                    array);
9295         if ((*decl == NULL_TREE)
9296             || (*decl == error_mark_node))
9297           return;
9298
9299         /* Calculate ((element - base) * NBBY) + init_offset.  */
9300         *offset = fold (build (MINUS_EXPR, TREE_TYPE (element),
9301                                element,
9302                                TYPE_MIN_VALUE (TYPE_DOMAIN
9303                                                (TREE_TYPE (array)))));
9304
9305         *offset = size_binop (MULT_EXPR,
9306                               convert (bitsizetype, *offset),
9307                               TYPE_SIZE (TREE_TYPE (TREE_TYPE (array))));
9308
9309         *offset = size_binop (PLUS_EXPR, init_offset, *offset);
9310
9311         *size = TYPE_SIZE (TREE_TYPE (t));
9312         return;
9313       }
9314
9315     case INDIRECT_REF:
9316
9317       /* Most of this code is to handle references to COMMON.  And so
9318          far that is useful only for calling library functions, since
9319          external (user) functions might reference common areas.  But
9320          even calling an external function, it's worthwhile to decode
9321          COMMON references because if not storing into COMMON, we don't
9322          want COMMON-based arguments to gratuitously force use of a
9323          temporary.  */
9324
9325       *size = TYPE_SIZE (TREE_TYPE (t));
9326
9327       ffecom_tree_canonize_ptr_ (decl, offset,
9328                                  TREE_OPERAND (t, 0));
9329
9330       return;
9331
9332     case CONVERT_EXPR:
9333     case NOP_EXPR:
9334     case MODIFY_EXPR:
9335     case NON_LVALUE_EXPR:
9336     case RESULT_DECL:
9337     case FIELD_DECL:
9338     case COND_EXPR:             /* More cases than we can handle. */
9339     case SAVE_EXPR:
9340     case REFERENCE_EXPR:
9341     case PREDECREMENT_EXPR:
9342     case PREINCREMENT_EXPR:
9343     case POSTDECREMENT_EXPR:
9344     case POSTINCREMENT_EXPR:
9345     case CALL_EXPR:
9346     default:
9347       *decl = error_mark_node;
9348       return;
9349     }
9350 }
9351 #endif
9352
9353 /* Do divide operation appropriate to type of operands.  */
9354
9355 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9356 static tree
9357 ffecom_tree_divide_ (tree tree_type, tree left, tree right,
9358                      tree dest_tree, ffebld dest, bool *dest_used,
9359                      tree hook)
9360 {
9361   if ((left == error_mark_node)
9362       || (right == error_mark_node))
9363     return error_mark_node;
9364
9365   switch (TREE_CODE (tree_type))
9366     {
9367     case INTEGER_TYPE:
9368       return ffecom_2 (TRUNC_DIV_EXPR, tree_type,
9369                        left,
9370                        right);
9371
9372     case COMPLEX_TYPE:
9373       if (! optimize_size)
9374         return ffecom_2 (RDIV_EXPR, tree_type,
9375                          left,
9376                          right);
9377       {
9378         ffecomGfrt ix;
9379
9380         if (TREE_TYPE (tree_type)
9381             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9382           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9383         else
9384           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9385
9386         left = ffecom_1 (ADDR_EXPR,
9387                          build_pointer_type (TREE_TYPE (left)),
9388                          left);
9389         left = build_tree_list (NULL_TREE, left);
9390         right = ffecom_1 (ADDR_EXPR,
9391                           build_pointer_type (TREE_TYPE (right)),
9392                           right);
9393         right = build_tree_list (NULL_TREE, right);
9394         TREE_CHAIN (left) = right;
9395
9396         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9397                              ffecom_gfrt_kindtype (ix),
9398                              ffe_is_f2c_library (),
9399                              tree_type,
9400                              left,
9401                              dest_tree, dest, dest_used,
9402                              NULL_TREE, TRUE, hook);
9403       }
9404       break;
9405
9406     case RECORD_TYPE:
9407       {
9408         ffecomGfrt ix;
9409
9410         if (TREE_TYPE (TYPE_FIELDS (tree_type))
9411             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9412           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9413         else
9414           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9415
9416         left = ffecom_1 (ADDR_EXPR,
9417                          build_pointer_type (TREE_TYPE (left)),
9418                          left);
9419         left = build_tree_list (NULL_TREE, left);
9420         right = ffecom_1 (ADDR_EXPR,
9421                           build_pointer_type (TREE_TYPE (right)),
9422                           right);
9423         right = build_tree_list (NULL_TREE, right);
9424         TREE_CHAIN (left) = right;
9425
9426         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9427                              ffecom_gfrt_kindtype (ix),
9428                              ffe_is_f2c_library (),
9429                              tree_type,
9430                              left,
9431                              dest_tree, dest, dest_used,
9432                              NULL_TREE, TRUE, hook);
9433       }
9434       break;
9435
9436     default:
9437       return ffecom_2 (RDIV_EXPR, tree_type,
9438                        left,
9439                        right);
9440     }
9441 }
9442
9443 #endif
9444 /* Build type info for non-dummy variable.  */
9445
9446 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9447 static tree
9448 ffecom_type_localvar_ (ffesymbol s, ffeinfoBasictype bt,
9449                        ffeinfoKindtype kt)
9450 {
9451   tree type;
9452   ffebld dl;
9453   ffebld dim;
9454   tree lowt;
9455   tree hight;
9456
9457   type = ffecom_tree_type[bt][kt];
9458   if (bt == FFEINFO_basictypeCHARACTER)
9459     {
9460       hight = build_int_2 (ffesymbol_size (s), 0);
9461       TREE_TYPE (hight) = ffecom_f2c_ftnlen_type_node;
9462
9463       type
9464         = build_array_type
9465           (type,
9466            build_range_type (ffecom_f2c_ftnlen_type_node,
9467                              ffecom_f2c_ftnlen_one_node,
9468                              hight));
9469       type = ffecom_check_size_overflow_ (s, type, FALSE);
9470     }
9471
9472   for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
9473     {
9474       if (type == error_mark_node)
9475         break;
9476
9477       dim = ffebld_head (dl);
9478       assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
9479
9480       if (ffebld_left (dim) == NULL)
9481         lowt = integer_one_node;
9482       else
9483         lowt = ffecom_expr (ffebld_left (dim));
9484
9485       if (TREE_CODE (lowt) != INTEGER_CST)
9486         lowt = variable_size (lowt);
9487
9488       assert (ffebld_right (dim) != NULL);
9489       hight = ffecom_expr (ffebld_right (dim));
9490
9491       if (TREE_CODE (hight) != INTEGER_CST)
9492         hight = variable_size (hight);
9493
9494       type = build_array_type (type,
9495                                build_range_type (ffecom_integer_type_node,
9496                                                  lowt, hight));
9497       type = ffecom_check_size_overflow_ (s, type, FALSE);
9498     }
9499
9500   return type;
9501 }
9502
9503 #endif
9504 /* Build Namelist type.  */
9505
9506 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9507 static tree
9508 ffecom_type_namelist_ ()
9509 {
9510   static tree type = NULL_TREE;
9511
9512   if (type == NULL_TREE)
9513     {
9514       static tree namefield, varsfield, nvarsfield;
9515       tree vardesctype;
9516
9517       vardesctype = ffecom_type_vardesc_ ();
9518
9519       type = make_node (RECORD_TYPE);
9520
9521       vardesctype = build_pointer_type (build_pointer_type (vardesctype));
9522
9523       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9524                                      string_type_node);
9525       varsfield = ffecom_decl_field (type, namefield, "vars", vardesctype);
9526       nvarsfield = ffecom_decl_field (type, varsfield, "nvars",
9527                                       integer_type_node);
9528
9529       TYPE_FIELDS (type) = namefield;
9530       layout_type (type);
9531
9532       ggc_add_tree_root (&type, 1);
9533     }
9534
9535   return type;
9536 }
9537
9538 #endif
9539
9540 /* Build Vardesc type.  */
9541
9542 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9543 static tree
9544 ffecom_type_vardesc_ ()
9545 {
9546   static tree type = NULL_TREE;
9547   static tree namefield, addrfield, dimsfield, typefield;
9548
9549   if (type == NULL_TREE)
9550     {
9551       type = make_node (RECORD_TYPE);
9552
9553       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9554                                      string_type_node);
9555       addrfield = ffecom_decl_field (type, namefield, "addr",
9556                                      string_type_node);
9557       dimsfield = ffecom_decl_field (type, addrfield, "dims",
9558                                      ffecom_f2c_ptr_to_ftnlen_type_node);
9559       typefield = ffecom_decl_field (type, dimsfield, "type",
9560                                      integer_type_node);
9561
9562       TYPE_FIELDS (type) = namefield;
9563       layout_type (type);
9564
9565       ggc_add_tree_root (&type, 1);
9566     }
9567
9568   return type;
9569 }
9570
9571 #endif
9572
9573 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9574 static tree
9575 ffecom_vardesc_ (ffebld expr)
9576 {
9577   ffesymbol s;
9578
9579   assert (ffebld_op (expr) == FFEBLD_opSYMTER);
9580   s = ffebld_symter (expr);
9581
9582   if (ffesymbol_hook (s).vardesc_tree == NULL_TREE)
9583     {
9584       int i;
9585       tree vardesctype = ffecom_type_vardesc_ ();
9586       tree var;
9587       tree nameinit;
9588       tree dimsinit;
9589       tree addrinit;
9590       tree typeinit;
9591       tree field;
9592       tree varinits;
9593       int yes;
9594       static int mynumber = 0;
9595
9596       yes = suspend_momentary ();
9597
9598       var = build_decl (VAR_DECL,
9599                         ffecom_get_invented_identifier ("__g77_vardesc_%d",
9600                                                         mynumber++),
9601                         vardesctype);
9602       TREE_STATIC (var) = 1;
9603       DECL_INITIAL (var) = error_mark_node;
9604
9605       var = start_decl (var, FALSE);
9606
9607       /* Process inits.  */
9608
9609       nameinit = ffecom_build_f2c_string_ ((i = strlen (ffesymbol_text (s)))
9610                                            + 1,
9611                                            ffesymbol_text (s));
9612       TREE_TYPE (nameinit)
9613         = build_type_variant
9614         (build_array_type
9615          (char_type_node,
9616           build_range_type (integer_type_node,
9617                             integer_one_node,
9618                             build_int_2 (i, 0))),
9619          1, 0);
9620       TREE_CONSTANT (nameinit) = 1;
9621       TREE_STATIC (nameinit) = 1;
9622       nameinit = ffecom_1 (ADDR_EXPR,
9623                            build_pointer_type (TREE_TYPE (nameinit)),
9624                            nameinit);
9625
9626       addrinit = ffecom_arg_ptr_to_expr (expr, &typeinit);
9627
9628       dimsinit = ffecom_vardesc_dims_ (s);
9629
9630       if (typeinit == NULL_TREE)
9631         {
9632           ffeinfoBasictype bt = ffesymbol_basictype (s);
9633           ffeinfoKindtype kt = ffesymbol_kindtype (s);
9634           int tc = ffecom_f2c_typecode (bt, kt);
9635
9636           assert (tc != -1);
9637           typeinit = build_int_2 (tc, (tc < 0) ? -1 : 0);
9638         }
9639       else
9640         typeinit = ffecom_1 (NEGATE_EXPR, TREE_TYPE (typeinit), typeinit);
9641
9642       varinits = build_tree_list ((field = TYPE_FIELDS (vardesctype)),
9643                                   nameinit);
9644       TREE_CHAIN (varinits) = build_tree_list ((field = TREE_CHAIN (field)),
9645                                                addrinit);
9646       TREE_CHAIN (TREE_CHAIN (varinits))
9647         = build_tree_list ((field = TREE_CHAIN (field)), dimsinit);
9648       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits)))
9649         = build_tree_list ((field = TREE_CHAIN (field)), typeinit);
9650
9651       varinits = build (CONSTRUCTOR, vardesctype, NULL_TREE, varinits);
9652       TREE_CONSTANT (varinits) = 1;
9653       TREE_STATIC (varinits) = 1;
9654
9655       finish_decl (var, varinits, FALSE);
9656
9657       var = ffecom_1 (ADDR_EXPR, build_pointer_type (vardesctype), var);
9658
9659       resume_momentary (yes);
9660
9661       ffesymbol_hook (s).vardesc_tree = var;
9662     }
9663
9664   return ffesymbol_hook (s).vardesc_tree;
9665 }
9666
9667 #endif
9668 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9669 static tree
9670 ffecom_vardesc_array_ (ffesymbol s)
9671 {
9672   ffebld b;
9673   tree list;
9674   tree item = NULL_TREE;
9675   tree var;
9676   int i;
9677   int yes;
9678   static int mynumber = 0;
9679
9680   for (i = 0, list = NULL_TREE, b = ffesymbol_namelist (s);
9681        b != NULL;
9682        b = ffebld_trail (b), ++i)
9683     {
9684       tree t;
9685
9686       t = ffecom_vardesc_ (ffebld_head (b));
9687
9688       if (list == NULL_TREE)
9689         list = item = build_tree_list (NULL_TREE, t);
9690       else
9691         {
9692           TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9693           item = TREE_CHAIN (item);
9694         }
9695     }
9696
9697   yes = suspend_momentary ();
9698
9699   item = build_array_type (build_pointer_type (ffecom_type_vardesc_ ()),
9700                            build_range_type (integer_type_node,
9701                                              integer_one_node,
9702                                              build_int_2 (i, 0)));
9703   list = build (CONSTRUCTOR, item, NULL_TREE, list);
9704   TREE_CONSTANT (list) = 1;
9705   TREE_STATIC (list) = 1;
9706
9707   var = ffecom_get_invented_identifier ("__g77_vardesc_array_%d", mynumber++);
9708   var = build_decl (VAR_DECL, var, item);
9709   TREE_STATIC (var) = 1;
9710   DECL_INITIAL (var) = error_mark_node;
9711   var = start_decl (var, FALSE);
9712   finish_decl (var, list, FALSE);
9713
9714   resume_momentary (yes);
9715
9716   return var;
9717 }
9718
9719 #endif
9720 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9721 static tree
9722 ffecom_vardesc_dims_ (ffesymbol s)
9723 {
9724   if (ffesymbol_dims (s) == NULL)
9725     return convert (ffecom_f2c_ptr_to_ftnlen_type_node,
9726                     integer_zero_node);
9727
9728   {
9729     ffebld b;
9730     ffebld e;
9731     tree list;
9732     tree backlist;
9733     tree item = NULL_TREE;
9734     tree var;
9735     int yes;
9736     tree numdim;
9737     tree numelem;
9738     tree baseoff = NULL_TREE;
9739     static int mynumber = 0;
9740
9741     numdim = build_int_2 ((int) ffesymbol_rank (s), 0);
9742     TREE_TYPE (numdim) = ffecom_f2c_ftnlen_type_node;
9743
9744     numelem = ffecom_expr (ffesymbol_arraysize (s));
9745     TREE_TYPE (numelem) = ffecom_f2c_ftnlen_type_node;
9746
9747     list = NULL_TREE;
9748     backlist = NULL_TREE;
9749     for (b = ffesymbol_dims (s), e = ffesymbol_extents (s);
9750          b != NULL;
9751          b = ffebld_trail (b), e = ffebld_trail (e))
9752       {
9753         tree t;
9754         tree low;
9755         tree back;
9756
9757         if (ffebld_trail (b) == NULL)
9758           t = NULL_TREE;
9759         else
9760           {
9761             t = convert (ffecom_f2c_ftnlen_type_node,
9762                          ffecom_expr (ffebld_head (e)));
9763
9764             if (list == NULL_TREE)
9765               list = item = build_tree_list (NULL_TREE, t);
9766             else
9767               {
9768                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9769                 item = TREE_CHAIN (item);
9770               }
9771           }
9772
9773         if (ffebld_left (ffebld_head (b)) == NULL)
9774           low = ffecom_integer_one_node;
9775         else
9776           low = ffecom_expr (ffebld_left (ffebld_head (b)));
9777         low = convert (ffecom_f2c_ftnlen_type_node, low);
9778
9779         back = build_tree_list (low, t);
9780         TREE_CHAIN (back) = backlist;
9781         backlist = back;
9782       }
9783
9784     for (item = backlist; item != NULL_TREE; item = TREE_CHAIN (item))
9785       {
9786         if (TREE_VALUE (item) == NULL_TREE)
9787           baseoff = TREE_PURPOSE (item);
9788         else
9789           baseoff = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
9790                               TREE_PURPOSE (item),
9791                               ffecom_2 (MULT_EXPR,
9792                                         ffecom_f2c_ftnlen_type_node,
9793                                         TREE_VALUE (item),
9794                                         baseoff));
9795       }
9796
9797     /* backlist now dead, along with all TREE_PURPOSEs on it.  */
9798
9799     baseoff = build_tree_list (NULL_TREE, baseoff);
9800     TREE_CHAIN (baseoff) = list;
9801
9802     numelem = build_tree_list (NULL_TREE, numelem);
9803     TREE_CHAIN (numelem) = baseoff;
9804
9805     numdim = build_tree_list (NULL_TREE, numdim);
9806     TREE_CHAIN (numdim) = numelem;
9807
9808     yes = suspend_momentary ();
9809
9810     item = build_array_type (ffecom_f2c_ftnlen_type_node,
9811                              build_range_type (integer_type_node,
9812                                                integer_zero_node,
9813                                                build_int_2
9814                                                ((int) ffesymbol_rank (s)
9815                                                 + 2, 0)));
9816     list = build (CONSTRUCTOR, item, NULL_TREE, numdim);
9817     TREE_CONSTANT (list) = 1;
9818     TREE_STATIC (list) = 1;
9819
9820     var = ffecom_get_invented_identifier ("__g77_dims_%d", mynumber++);
9821     var = build_decl (VAR_DECL, var, item);
9822     TREE_STATIC (var) = 1;
9823     DECL_INITIAL (var) = error_mark_node;
9824     var = start_decl (var, FALSE);
9825     finish_decl (var, list, FALSE);
9826
9827     var = ffecom_1 (ADDR_EXPR, build_pointer_type (item), var);
9828
9829     resume_momentary (yes);
9830
9831     return var;
9832   }
9833 }
9834
9835 #endif
9836 /* Essentially does a "fold (build1 (code, type, node))" while checking
9837    for certain housekeeping things.
9838
9839    NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
9840    ffecom_1_fn instead.  */
9841
9842 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9843 tree
9844 ffecom_1 (enum tree_code code, tree type, tree node)
9845 {
9846   tree item;
9847
9848   if ((node == error_mark_node)
9849       || (type == error_mark_node))
9850     return error_mark_node;
9851
9852   if (code == ADDR_EXPR)
9853     {
9854       if (!mark_addressable (node))
9855         assert ("can't mark_addressable this node!" == NULL);
9856     }
9857
9858   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9859     {
9860       tree realtype;
9861
9862     case REALPART_EXPR:
9863       item = build (COMPONENT_REF, type, node, TYPE_FIELDS (TREE_TYPE (node)));
9864       break;
9865
9866     case IMAGPART_EXPR:
9867       item = build (COMPONENT_REF, type, node, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node))));
9868       break;
9869
9870
9871     case NEGATE_EXPR:
9872       if (TREE_CODE (type) != RECORD_TYPE)
9873         {
9874           item = build1 (code, type, node);
9875           break;
9876         }
9877       node = ffecom_stabilize_aggregate_ (node);
9878       realtype = TREE_TYPE (TYPE_FIELDS (type));
9879       item =
9880         ffecom_2 (COMPLEX_EXPR, type,
9881                   ffecom_1 (NEGATE_EXPR, realtype,
9882                             ffecom_1 (REALPART_EXPR, realtype,
9883                                       node)),
9884                   ffecom_1 (NEGATE_EXPR, realtype,
9885                             ffecom_1 (IMAGPART_EXPR, realtype,
9886                                       node)));
9887       break;
9888
9889     default:
9890       item = build1 (code, type, node);
9891       break;
9892     }
9893
9894   if (TREE_SIDE_EFFECTS (node))
9895     TREE_SIDE_EFFECTS (item) = 1;
9896   if ((code == ADDR_EXPR) && staticp (node))
9897     TREE_CONSTANT (item) = 1;
9898   return fold (item);
9899 }
9900 #endif
9901
9902 /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
9903    handles TREE_CODE (node) == FUNCTION_DECL.  In particular,
9904    does not set TREE_ADDRESSABLE (because calling an inline
9905    function does not mean the function needs to be separately
9906    compiled).  */
9907
9908 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9909 tree
9910 ffecom_1_fn (tree node)
9911 {
9912   tree item;
9913   tree type;
9914
9915   if (node == error_mark_node)
9916     return error_mark_node;
9917
9918   type = build_type_variant (TREE_TYPE (node),
9919                              TREE_READONLY (node),
9920                              TREE_THIS_VOLATILE (node));
9921   item = build1 (ADDR_EXPR,
9922                  build_pointer_type (type), node);
9923   if (TREE_SIDE_EFFECTS (node))
9924     TREE_SIDE_EFFECTS (item) = 1;
9925   if (staticp (node))
9926     TREE_CONSTANT (item) = 1;
9927   return fold (item);
9928 }
9929 #endif
9930
9931 /* Essentially does a "fold (build (code, type, node1, node2))" while
9932    checking for certain housekeeping things.  */
9933
9934 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9935 tree
9936 ffecom_2 (enum tree_code code, tree type, tree node1,
9937           tree node2)
9938 {
9939   tree item;
9940
9941   if ((node1 == error_mark_node)
9942       || (node2 == error_mark_node)
9943       || (type == error_mark_node))
9944     return error_mark_node;
9945
9946   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9947     {
9948       tree a, b, c, d, realtype;
9949
9950     case CONJ_EXPR:
9951       assert ("no CONJ_EXPR support yet" == NULL);
9952       return error_mark_node;
9953
9954     case COMPLEX_EXPR:
9955       item = build_tree_list (TYPE_FIELDS (type), node1);
9956       TREE_CHAIN (item) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), node2);
9957       item = build (CONSTRUCTOR, type, NULL_TREE, item);
9958       break;
9959
9960     case PLUS_EXPR:
9961       if (TREE_CODE (type) != RECORD_TYPE)
9962         {
9963           item = build (code, type, node1, node2);
9964           break;
9965         }
9966       node1 = ffecom_stabilize_aggregate_ (node1);
9967       node2 = ffecom_stabilize_aggregate_ (node2);
9968       realtype = TREE_TYPE (TYPE_FIELDS (type));
9969       item =
9970         ffecom_2 (COMPLEX_EXPR, type,
9971                   ffecom_2 (PLUS_EXPR, realtype,
9972                             ffecom_1 (REALPART_EXPR, realtype,
9973                                       node1),
9974                             ffecom_1 (REALPART_EXPR, realtype,
9975                                       node2)),
9976                   ffecom_2 (PLUS_EXPR, realtype,
9977                             ffecom_1 (IMAGPART_EXPR, realtype,
9978                                       node1),
9979                             ffecom_1 (IMAGPART_EXPR, realtype,
9980                                       node2)));
9981       break;
9982
9983     case MINUS_EXPR:
9984       if (TREE_CODE (type) != RECORD_TYPE)
9985         {
9986           item = build (code, type, node1, node2);
9987           break;
9988         }
9989       node1 = ffecom_stabilize_aggregate_ (node1);
9990       node2 = ffecom_stabilize_aggregate_ (node2);
9991       realtype = TREE_TYPE (TYPE_FIELDS (type));
9992       item =
9993         ffecom_2 (COMPLEX_EXPR, type,
9994                   ffecom_2 (MINUS_EXPR, realtype,
9995                             ffecom_1 (REALPART_EXPR, realtype,
9996                                       node1),
9997                             ffecom_1 (REALPART_EXPR, realtype,
9998                                       node2)),
9999                   ffecom_2 (MINUS_EXPR, realtype,
10000                             ffecom_1 (IMAGPART_EXPR, realtype,
10001                                       node1),
10002                             ffecom_1 (IMAGPART_EXPR, realtype,
10003                                       node2)));
10004       break;
10005
10006     case MULT_EXPR:
10007       if (TREE_CODE (type) != RECORD_TYPE)
10008         {
10009           item = build (code, type, node1, node2);
10010           break;
10011         }
10012       node1 = ffecom_stabilize_aggregate_ (node1);
10013       node2 = ffecom_stabilize_aggregate_ (node2);
10014       realtype = TREE_TYPE (TYPE_FIELDS (type));
10015       a = save_expr (ffecom_1 (REALPART_EXPR, realtype,
10016                                node1));
10017       b = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
10018                                node1));
10019       c = save_expr (ffecom_1 (REALPART_EXPR, realtype,
10020                                node2));
10021       d = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
10022                                node2));
10023       item =
10024         ffecom_2 (COMPLEX_EXPR, type,
10025                   ffecom_2 (MINUS_EXPR, realtype,
10026                             ffecom_2 (MULT_EXPR, realtype,
10027                                       a,
10028                                       c),
10029                             ffecom_2 (MULT_EXPR, realtype,
10030                                       b,
10031                                       d)),
10032                   ffecom_2 (PLUS_EXPR, realtype,
10033                             ffecom_2 (MULT_EXPR, realtype,
10034                                       a,
10035                                       d),
10036                             ffecom_2 (MULT_EXPR, realtype,
10037                                       c,
10038                                       b)));
10039       break;
10040
10041     case EQ_EXPR:
10042       if ((TREE_CODE (node1) != RECORD_TYPE)
10043           && (TREE_CODE (node2) != RECORD_TYPE))
10044         {
10045           item = build (code, type, node1, node2);
10046           break;
10047         }
10048       assert (TREE_CODE (node1) == RECORD_TYPE);
10049       assert (TREE_CODE (node2) == RECORD_TYPE);
10050       node1 = ffecom_stabilize_aggregate_ (node1);
10051       node2 = ffecom_stabilize_aggregate_ (node2);
10052       realtype = TREE_TYPE (TYPE_FIELDS (type));
10053       item =
10054         ffecom_2 (TRUTH_ANDIF_EXPR, type,
10055                   ffecom_2 (code, type,
10056                             ffecom_1 (REALPART_EXPR, realtype,
10057                                       node1),
10058                             ffecom_1 (REALPART_EXPR, realtype,
10059                                       node2)),
10060                   ffecom_2 (code, type,
10061                             ffecom_1 (IMAGPART_EXPR, realtype,
10062                                       node1),
10063                             ffecom_1 (IMAGPART_EXPR, realtype,
10064                                       node2)));
10065       break;
10066
10067     case NE_EXPR:
10068       if ((TREE_CODE (node1) != RECORD_TYPE)
10069           && (TREE_CODE (node2) != RECORD_TYPE))
10070         {
10071           item = build (code, type, node1, node2);
10072           break;
10073         }
10074       assert (TREE_CODE (node1) == RECORD_TYPE);
10075       assert (TREE_CODE (node2) == RECORD_TYPE);
10076       node1 = ffecom_stabilize_aggregate_ (node1);
10077       node2 = ffecom_stabilize_aggregate_ (node2);
10078       realtype = TREE_TYPE (TYPE_FIELDS (type));
10079       item =
10080         ffecom_2 (TRUTH_ORIF_EXPR, type,
10081                   ffecom_2 (code, type,
10082                             ffecom_1 (REALPART_EXPR, realtype,
10083                                       node1),
10084                             ffecom_1 (REALPART_EXPR, realtype,
10085                                       node2)),
10086                   ffecom_2 (code, type,
10087                             ffecom_1 (IMAGPART_EXPR, realtype,
10088                                       node1),
10089                             ffecom_1 (IMAGPART_EXPR, realtype,
10090                                       node2)));
10091       break;
10092
10093     default:
10094       item = build (code, type, node1, node2);
10095       break;
10096     }
10097
10098   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2))
10099     TREE_SIDE_EFFECTS (item) = 1;
10100   return fold (item);
10101 }
10102
10103 #endif
10104 /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
10105
10106    ffesymbol s;  // the ENTRY point itself
10107    if (ffecom_2pass_advise_entrypoint(s))
10108        // the ENTRY point has been accepted
10109
10110    Does whatever compiler needs to do when it learns about the entrypoint,
10111    like determine the return type of the master function, count the
10112    number of entrypoints, etc.  Returns FALSE if the return type is
10113    not compatible with the return type(s) of other entrypoint(s).
10114
10115    NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
10116    later (after _finish_progunit) be called with the same entrypoint(s)
10117    as passed to this fn for which TRUE was returned.
10118
10119    03-Jan-92  JCB  2.0
10120       Return FALSE if the return type conflicts with previous entrypoints.  */
10121
10122 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10123 bool
10124 ffecom_2pass_advise_entrypoint (ffesymbol entry)
10125 {
10126   ffebld list;                  /* opITEM. */
10127   ffebld mlist;                 /* opITEM. */
10128   ffebld plist;                 /* opITEM. */
10129   ffebld arg;                   /* ffebld_head(opITEM). */
10130   ffebld item;                  /* opITEM. */
10131   ffesymbol s;                  /* ffebld_symter(arg). */
10132   ffeinfoBasictype bt = ffesymbol_basictype (entry);
10133   ffeinfoKindtype kt = ffesymbol_kindtype (entry);
10134   ffetargetCharacterSize size = ffesymbol_size (entry);
10135   bool ok;
10136
10137   if (ffecom_num_entrypoints_ == 0)
10138     {                           /* First entrypoint, make list of main
10139                                    arglist's dummies. */
10140       assert (ffecom_primary_entry_ != NULL);
10141
10142       ffecom_master_bt_ = ffesymbol_basictype (ffecom_primary_entry_);
10143       ffecom_master_kt_ = ffesymbol_kindtype (ffecom_primary_entry_);
10144       ffecom_master_size_ = ffesymbol_size (ffecom_primary_entry_);
10145
10146       for (plist = NULL, list = ffesymbol_dummyargs (ffecom_primary_entry_);
10147            list != NULL;
10148            list = ffebld_trail (list))
10149         {
10150           arg = ffebld_head (list);
10151           if (ffebld_op (arg) != FFEBLD_opSYMTER)
10152             continue;           /* Alternate return or some such thing. */
10153           item = ffebld_new_item (arg, NULL);
10154           if (plist == NULL)
10155             ffecom_master_arglist_ = item;
10156           else
10157             ffebld_set_trail (plist, item);
10158           plist = item;
10159         }
10160     }
10161
10162   /* If necessary, scan entry arglist for alternate returns.  Do this scan
10163      apparently redundantly (it's done below to UNIONize the arglists) so
10164      that we don't complain about RETURN 1 if an offending ENTRY is the only
10165      one with an alternate return.  */
10166
10167   if (!ffecom_is_altreturning_)
10168     {
10169       for (list = ffesymbol_dummyargs (entry);
10170            list != NULL;
10171            list = ffebld_trail (list))
10172         {
10173           arg = ffebld_head (list);
10174           if (ffebld_op (arg) == FFEBLD_opSTAR)
10175             {
10176               ffecom_is_altreturning_ = TRUE;
10177               break;
10178             }
10179         }
10180     }
10181
10182   /* Now check type compatibility. */
10183
10184   switch (ffecom_master_bt_)
10185     {
10186     case FFEINFO_basictypeNONE:
10187       ok = (bt != FFEINFO_basictypeCHARACTER);
10188       break;
10189
10190     case FFEINFO_basictypeCHARACTER:
10191       ok
10192         = (bt == FFEINFO_basictypeCHARACTER)
10193         && (kt == ffecom_master_kt_)
10194         && (size == ffecom_master_size_);
10195       break;
10196
10197     case FFEINFO_basictypeANY:
10198       return FALSE;             /* Just don't bother. */
10199
10200     default:
10201       if (bt == FFEINFO_basictypeCHARACTER)
10202         {
10203           ok = FALSE;
10204           break;
10205         }
10206       ok = TRUE;
10207       if ((bt != ffecom_master_bt_) || (kt != ffecom_master_kt_))
10208         {
10209           ffecom_master_bt_ = FFEINFO_basictypeNONE;
10210           ffecom_master_kt_ = FFEINFO_kindtypeNONE;
10211         }
10212       break;
10213     }
10214
10215   if (!ok)
10216     {
10217       ffebad_start (FFEBAD_ENTRY_CONFLICTS);
10218       ffest_ffebad_here_current_stmt (0);
10219       ffebad_finish ();
10220       return FALSE;             /* Can't handle entrypoint. */
10221     }
10222
10223   /* Entrypoint type compatible with previous types. */
10224
10225   ++ffecom_num_entrypoints_;
10226
10227   /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
10228
10229   for (list = ffesymbol_dummyargs (entry);
10230        list != NULL;
10231        list = ffebld_trail (list))
10232     {
10233       arg = ffebld_head (list);
10234       if (ffebld_op (arg) != FFEBLD_opSYMTER)
10235         continue;               /* Alternate return or some such thing. */
10236       s = ffebld_symter (arg);
10237       for (plist = NULL, mlist = ffecom_master_arglist_;
10238            mlist != NULL;
10239            plist = mlist, mlist = ffebld_trail (mlist))
10240         {                       /* plist points to previous item for easy
10241                                    appending of arg. */
10242           if (ffebld_symter (ffebld_head (mlist)) == s)
10243             break;              /* Already have this arg in the master list. */
10244         }
10245       if (mlist != NULL)
10246         continue;               /* Already have this arg in the master list. */
10247
10248       /* Append this arg to the master list. */
10249
10250       item = ffebld_new_item (arg, NULL);
10251       if (plist == NULL)
10252         ffecom_master_arglist_ = item;
10253       else
10254         ffebld_set_trail (plist, item);
10255     }
10256
10257   return TRUE;
10258 }
10259
10260 #endif
10261 /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
10262
10263    ffesymbol s;  // the ENTRY point itself
10264    ffecom_2pass_do_entrypoint(s);
10265
10266    Does whatever compiler needs to do to make the entrypoint actually
10267    happen.  Must be called for each entrypoint after
10268    ffecom_finish_progunit is called.  */
10269
10270 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10271 void
10272 ffecom_2pass_do_entrypoint (ffesymbol entry)
10273 {
10274   static int mfn_num = 0;
10275   static int ent_num;
10276
10277   if (mfn_num != ffecom_num_fns_)
10278     {                           /* First entrypoint for this program unit. */
10279       ent_num = 1;
10280       mfn_num = ffecom_num_fns_;
10281       ffecom_do_entry_ (ffecom_primary_entry_, 0);
10282     }
10283   else
10284     ++ent_num;
10285
10286   --ffecom_num_entrypoints_;
10287
10288   ffecom_do_entry_ (entry, ent_num);
10289 }
10290
10291 #endif
10292
10293 /* Essentially does a "fold (build (code, type, node1, node2))" while
10294    checking for certain housekeeping things.  Always sets
10295    TREE_SIDE_EFFECTS.  */
10296
10297 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10298 tree
10299 ffecom_2s (enum tree_code code, tree type, tree node1,
10300            tree node2)
10301 {
10302   tree item;
10303
10304   if ((node1 == error_mark_node)
10305       || (node2 == error_mark_node)
10306       || (type == error_mark_node))
10307     return error_mark_node;
10308
10309   item = build (code, type, node1, node2);
10310   TREE_SIDE_EFFECTS (item) = 1;
10311   return fold (item);
10312 }
10313
10314 #endif
10315 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10316    checking for certain housekeeping things.  */
10317
10318 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10319 tree
10320 ffecom_3 (enum tree_code code, tree type, tree node1,
10321           tree node2, tree node3)
10322 {
10323   tree item;
10324
10325   if ((node1 == error_mark_node)
10326       || (node2 == error_mark_node)
10327       || (node3 == error_mark_node)
10328       || (type == error_mark_node))
10329     return error_mark_node;
10330
10331   item = build (code, type, node1, node2, node3);
10332   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2)
10333       || (node3 != NULL_TREE && TREE_SIDE_EFFECTS (node3)))
10334     TREE_SIDE_EFFECTS (item) = 1;
10335   return fold (item);
10336 }
10337
10338 #endif
10339 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10340    checking for certain housekeeping things.  Always sets
10341    TREE_SIDE_EFFECTS.  */
10342
10343 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10344 tree
10345 ffecom_3s (enum tree_code code, tree type, tree node1,
10346            tree node2, tree node3)
10347 {
10348   tree item;
10349
10350   if ((node1 == error_mark_node)
10351       || (node2 == error_mark_node)
10352       || (node3 == error_mark_node)
10353       || (type == error_mark_node))
10354     return error_mark_node;
10355
10356   item = build (code, type, node1, node2, node3);
10357   TREE_SIDE_EFFECTS (item) = 1;
10358   return fold (item);
10359 }
10360
10361 #endif
10362
10363 /* ffecom_arg_expr -- Transform argument expr into gcc tree
10364
10365    See use by ffecom_list_expr.
10366
10367    If expression is NULL, returns an integer zero tree.  If it is not
10368    a CHARACTER expression, returns whatever ffecom_expr
10369    returns and sets the length return value to NULL_TREE.  Otherwise
10370    generates code to evaluate the character expression, returns the proper
10371    pointer to the result, but does NOT set the length return value to a tree
10372    that specifies the length of the result.  (In other words, the length
10373    variable is always set to NULL_TREE, because a length is never passed.)
10374
10375    21-Dec-91  JCB  1.1
10376       Don't set returned length, since nobody needs it (yet; someday if
10377       we allow CHARACTER*(*) dummies to statement functions, we'll need
10378       it).  */
10379
10380 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10381 tree
10382 ffecom_arg_expr (ffebld expr, tree *length)
10383 {
10384   tree ign;
10385
10386   *length = NULL_TREE;
10387
10388   if (expr == NULL)
10389     return integer_zero_node;
10390
10391   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10392     return ffecom_expr (expr);
10393
10394   return ffecom_arg_ptr_to_expr (expr, &ign);
10395 }
10396
10397 #endif
10398 /* Transform expression into constant argument-pointer-to-expression tree.
10399
10400    If the expression can be transformed into a argument-pointer-to-expression
10401    tree that is constant, that is done, and the tree returned.  Else
10402    NULL_TREE is returned.
10403
10404    That way, a caller can attempt to provide compile-time initialization
10405    of a variable and, if that fails, *then* choose to start a new block
10406    and resort to using temporaries, as appropriate.  */
10407
10408 tree
10409 ffecom_arg_ptr_to_const_expr (ffebld expr, tree *length)
10410 {
10411   if (! expr)
10412     return integer_zero_node;
10413
10414   if (ffebld_op (expr) == FFEBLD_opANY)
10415     {
10416       if (length)
10417         *length = error_mark_node;
10418       return error_mark_node;
10419     }
10420
10421   if (ffebld_arity (expr) == 0
10422       && (ffebld_op (expr) != FFEBLD_opSYMTER
10423           || ffebld_where (expr) == FFEINFO_whereCOMMON
10424           || ffebld_where (expr) == FFEINFO_whereGLOBAL
10425           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10426     {
10427       tree t;
10428
10429       t = ffecom_arg_ptr_to_expr (expr, length);
10430       assert (TREE_CONSTANT (t));
10431       assert (! length || TREE_CONSTANT (*length));
10432       return t;
10433     }
10434
10435   if (length
10436       && ffebld_size (expr) != FFETARGET_charactersizeNONE)
10437     *length = build_int_2 (ffebld_size (expr), 0);
10438   else if (length)
10439     *length = NULL_TREE;
10440   return NULL_TREE;
10441 }
10442
10443 /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
10444
10445    See use by ffecom_list_ptr_to_expr.
10446
10447    If expression is NULL, returns an integer zero tree.  If it is not
10448    a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10449    returns and sets the length return value to NULL_TREE.  Otherwise
10450    generates code to evaluate the character expression, returns the proper
10451    pointer to the result, AND sets the length return value to a tree that
10452    specifies the length of the result.
10453
10454    If the length argument is NULL, this is a slightly special
10455    case of building a FORMAT expression, that is, an expression that
10456    will be used at run time without regard to length.  For the current
10457    implementation, which uses the libf2c library, this means it is nice
10458    to append a null byte to the end of the expression, where feasible,
10459    to make sure any diagnostic about the FORMAT string terminates at
10460    some useful point.
10461
10462    For now, treat %REF(char-expr) as the same as char-expr with a NULL
10463    length argument.  This might even be seen as a feature, if a null
10464    byte can always be appended.  */
10465
10466 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10467 tree
10468 ffecom_arg_ptr_to_expr (ffebld expr, tree *length)
10469 {
10470   tree item;
10471   tree ign_length;
10472   ffecomConcatList_ catlist;
10473
10474   if (length != NULL)
10475     *length = NULL_TREE;
10476
10477   if (expr == NULL)
10478     return integer_zero_node;
10479
10480   switch (ffebld_op (expr))
10481     {
10482     case FFEBLD_opPERCENT_VAL:
10483       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10484         return ffecom_expr (ffebld_left (expr));
10485       {
10486         tree temp_exp;
10487         tree temp_length;
10488
10489         temp_exp = ffecom_arg_ptr_to_expr (ffebld_left (expr), &temp_length);
10490         if (temp_exp == error_mark_node)
10491           return error_mark_node;
10492
10493         return ffecom_1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (temp_exp)),
10494                          temp_exp);
10495       }
10496
10497     case FFEBLD_opPERCENT_REF:
10498       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10499         return ffecom_ptr_to_expr (ffebld_left (expr));
10500       if (length != NULL)
10501         {
10502           ign_length = NULL_TREE;
10503           length = &ign_length;
10504         }
10505       expr = ffebld_left (expr);
10506       break;
10507
10508     case FFEBLD_opPERCENT_DESCR:
10509       switch (ffeinfo_basictype (ffebld_info (expr)))
10510         {
10511 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10512         case FFEINFO_basictypeHOLLERITH:
10513 #endif
10514         case FFEINFO_basictypeCHARACTER:
10515           break;                /* Passed by descriptor anyway. */
10516
10517         default:
10518           item = ffecom_ptr_to_expr (expr);
10519           if (item != error_mark_node)
10520             *length = TYPE_SIZE (TREE_TYPE (TREE_TYPE (item)));
10521           break;
10522         }
10523       break;
10524
10525     default:
10526       break;
10527     }
10528
10529 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10530   if ((ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeHOLLERITH)
10531       && (length != NULL))
10532     {                           /* Pass Hollerith by descriptor. */
10533       ffetargetHollerith h;
10534
10535       assert (ffebld_op (expr) == FFEBLD_opCONTER);
10536       h = ffebld_cu_val_hollerith (ffebld_constant_union
10537                                    (ffebld_conter (expr)));
10538       *length
10539         = build_int_2 (h.length, 0);
10540       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10541     }
10542 #endif
10543
10544   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10545     return ffecom_ptr_to_expr (expr);
10546
10547   assert (ffeinfo_kindtype (ffebld_info (expr))
10548           == FFEINFO_kindtypeCHARACTER1);
10549
10550   while (ffebld_op (expr) == FFEBLD_opPAREN)
10551     expr = ffebld_left (expr);
10552
10553   catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
10554   switch (ffecom_concat_list_count_ (catlist))
10555     {
10556     case 0:                     /* Shouldn't happen, but in case it does... */
10557       if (length != NULL)
10558         {
10559           *length = ffecom_f2c_ftnlen_zero_node;
10560           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10561         }
10562       ffecom_concat_list_kill_ (catlist);
10563       return null_pointer_node;
10564
10565     case 1:                     /* The (fairly) easy case. */
10566       if (length == NULL)
10567         ffecom_char_args_with_null_ (&item, &ign_length,
10568                                      ffecom_concat_list_expr_ (catlist, 0));
10569       else
10570         ffecom_char_args_ (&item, length,
10571                            ffecom_concat_list_expr_ (catlist, 0));
10572       ffecom_concat_list_kill_ (catlist);
10573       assert (item != NULL_TREE);
10574       return item;
10575
10576     default:                    /* Must actually concatenate things. */
10577       break;
10578     }
10579
10580   {
10581     int count = ffecom_concat_list_count_ (catlist);
10582     int i;
10583     tree lengths;
10584     tree items;
10585     tree length_array;
10586     tree item_array;
10587     tree citem;
10588     tree clength;
10589     tree temporary;
10590     tree num;
10591     tree known_length;
10592     ffetargetCharacterSize sz;
10593
10594     sz = ffecom_concat_list_maxlen_ (catlist);
10595     /* ~~Kludge! */
10596     assert (sz != FFETARGET_charactersizeNONE);
10597
10598 #ifdef HOHO
10599     length_array
10600       = lengths
10601       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
10602                              FFETARGET_charactersizeNONE, count, TRUE);
10603     item_array
10604       = items
10605       = ffecom_push_tempvar (ffecom_f2c_address_type_node,
10606                              FFETARGET_charactersizeNONE, count, TRUE);
10607     temporary = ffecom_push_tempvar (char_type_node,
10608                                      sz, -1, TRUE);
10609 #else
10610     {
10611       tree hook;
10612
10613       hook = ffebld_nonter_hook (expr);
10614       assert (hook);
10615       assert (TREE_CODE (hook) == TREE_VEC);
10616       assert (TREE_VEC_LENGTH (hook) == 3);
10617       length_array = lengths = TREE_VEC_ELT (hook, 0);
10618       item_array = items = TREE_VEC_ELT (hook, 1);
10619       temporary = TREE_VEC_ELT (hook, 2);
10620     }
10621 #endif
10622
10623     known_length = ffecom_f2c_ftnlen_zero_node;
10624
10625     for (i = 0; i < count; ++i)
10626       {
10627         if ((i == count)
10628             && (length == NULL))
10629           ffecom_char_args_with_null_ (&citem, &clength,
10630                                        ffecom_concat_list_expr_ (catlist, i));
10631         else
10632           ffecom_char_args_ (&citem, &clength,
10633                              ffecom_concat_list_expr_ (catlist, i));
10634         if ((citem == error_mark_node)
10635             || (clength == error_mark_node))
10636           {
10637             ffecom_concat_list_kill_ (catlist);
10638             *length = error_mark_node;
10639             return error_mark_node;
10640           }
10641
10642         items
10643           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
10644                       ffecom_modify (void_type_node,
10645                                      ffecom_2 (ARRAY_REF,
10646                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
10647                                                item_array,
10648                                                build_int_2 (i, 0)),
10649                                      citem),
10650                       items);
10651         clength = ffecom_save_tree (clength);
10652         if (length != NULL)
10653           known_length
10654             = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
10655                         known_length,
10656                         clength);
10657         lengths
10658           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
10659                       ffecom_modify (void_type_node,
10660                                      ffecom_2 (ARRAY_REF,
10661                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
10662                                                length_array,
10663                                                build_int_2 (i, 0)),
10664                                      clength),
10665                       lengths);
10666       }
10667
10668     temporary = ffecom_1 (ADDR_EXPR,
10669                           build_pointer_type (TREE_TYPE (temporary)),
10670                           temporary);
10671
10672     item = build_tree_list (NULL_TREE, temporary);
10673     TREE_CHAIN (item)
10674       = build_tree_list (NULL_TREE,
10675                          ffecom_1 (ADDR_EXPR,
10676                                    build_pointer_type (TREE_TYPE (items)),
10677                                    items));
10678     TREE_CHAIN (TREE_CHAIN (item))
10679       = build_tree_list (NULL_TREE,
10680                          ffecom_1 (ADDR_EXPR,
10681                                    build_pointer_type (TREE_TYPE (lengths)),
10682                                    lengths));
10683     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
10684       = build_tree_list
10685         (NULL_TREE,
10686          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
10687                    convert (ffecom_f2c_ftnlen_type_node,
10688                             build_int_2 (count, 0))));
10689     num = build_int_2 (sz, 0);
10690     TREE_TYPE (num) = ffecom_f2c_ftnlen_type_node;
10691     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item))))
10692       = build_tree_list (NULL_TREE, num);
10693
10694     item = ffecom_call_gfrt (FFECOM_gfrtCAT, item, NULL_TREE);
10695     TREE_SIDE_EFFECTS (item) = 1;
10696     item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (temporary),
10697                      item,
10698                      temporary);
10699
10700     if (length != NULL)
10701       *length = known_length;
10702   }
10703
10704   ffecom_concat_list_kill_ (catlist);
10705   assert (item != NULL_TREE);
10706   return item;
10707 }
10708
10709 #endif
10710 /* Generate call to run-time function.
10711
10712    The first arg is the GNU Fortran Run-Time function index, the second
10713    arg is the list of arguments to pass to it.  Returned is the expression
10714    (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
10715    result (which may be void).  */
10716
10717 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10718 tree
10719 ffecom_call_gfrt (ffecomGfrt ix, tree args, tree hook)
10720 {
10721   return ffecom_call_ (ffecom_gfrt_tree_ (ix),
10722                        ffecom_gfrt_kindtype (ix),
10723                        ffe_is_f2c_library () && ffecom_gfrt_complex_[ix],
10724                        NULL_TREE, args, NULL_TREE, NULL,
10725                        NULL, NULL_TREE, TRUE, hook);
10726 }
10727 #endif
10728
10729 /* Transform constant-union to tree.  */
10730
10731 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10732 tree
10733 ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt,
10734                       ffeinfoKindtype kt, tree tree_type)
10735 {
10736   tree item;
10737
10738   switch (bt)
10739     {
10740     case FFEINFO_basictypeINTEGER:
10741       {
10742         int val;
10743
10744         switch (kt)
10745           {
10746 #if FFETARGET_okINTEGER1
10747           case FFEINFO_kindtypeINTEGER1:
10748             val = ffebld_cu_val_integer1 (*cu);
10749             break;
10750 #endif
10751
10752 #if FFETARGET_okINTEGER2
10753           case FFEINFO_kindtypeINTEGER2:
10754             val = ffebld_cu_val_integer2 (*cu);
10755             break;
10756 #endif
10757
10758 #if FFETARGET_okINTEGER3
10759           case FFEINFO_kindtypeINTEGER3:
10760             val = ffebld_cu_val_integer3 (*cu);
10761             break;
10762 #endif
10763
10764 #if FFETARGET_okINTEGER4
10765           case FFEINFO_kindtypeINTEGER4:
10766             val = ffebld_cu_val_integer4 (*cu);
10767             break;
10768 #endif
10769
10770           default:
10771             assert ("bad INTEGER constant kind type" == NULL);
10772             /* Fall through. */
10773           case FFEINFO_kindtypeANY:
10774             return error_mark_node;
10775           }
10776         item = build_int_2 (val, (val < 0) ? -1 : 0);
10777         TREE_TYPE (item) = tree_type;
10778       }
10779       break;
10780
10781     case FFEINFO_basictypeLOGICAL:
10782       {
10783         int val;
10784
10785         switch (kt)
10786           {
10787 #if FFETARGET_okLOGICAL1
10788           case FFEINFO_kindtypeLOGICAL1:
10789             val = ffebld_cu_val_logical1 (*cu);
10790             break;
10791 #endif
10792
10793 #if FFETARGET_okLOGICAL2
10794           case FFEINFO_kindtypeLOGICAL2:
10795             val = ffebld_cu_val_logical2 (*cu);
10796             break;
10797 #endif
10798
10799 #if FFETARGET_okLOGICAL3
10800           case FFEINFO_kindtypeLOGICAL3:
10801             val = ffebld_cu_val_logical3 (*cu);
10802             break;
10803 #endif
10804
10805 #if FFETARGET_okLOGICAL4
10806           case FFEINFO_kindtypeLOGICAL4:
10807             val = ffebld_cu_val_logical4 (*cu);
10808             break;
10809 #endif
10810
10811           default:
10812             assert ("bad LOGICAL constant kind type" == NULL);
10813             /* Fall through. */
10814           case FFEINFO_kindtypeANY:
10815             return error_mark_node;
10816           }
10817         item = build_int_2 (val, (val < 0) ? -1 : 0);
10818         TREE_TYPE (item) = tree_type;
10819       }
10820       break;
10821
10822     case FFEINFO_basictypeREAL:
10823       {
10824         REAL_VALUE_TYPE val;
10825
10826         switch (kt)
10827           {
10828 #if FFETARGET_okREAL1
10829           case FFEINFO_kindtypeREAL1:
10830             val = ffetarget_value_real1 (ffebld_cu_val_real1 (*cu));
10831             break;
10832 #endif
10833
10834 #if FFETARGET_okREAL2
10835           case FFEINFO_kindtypeREAL2:
10836             val = ffetarget_value_real2 (ffebld_cu_val_real2 (*cu));
10837             break;
10838 #endif
10839
10840 #if FFETARGET_okREAL3
10841           case FFEINFO_kindtypeREAL3:
10842             val = ffetarget_value_real3 (ffebld_cu_val_real3 (*cu));
10843             break;
10844 #endif
10845
10846 #if FFETARGET_okREAL4
10847           case FFEINFO_kindtypeREAL4:
10848             val = ffetarget_value_real4 (ffebld_cu_val_real4 (*cu));
10849             break;
10850 #endif
10851
10852           default:
10853             assert ("bad REAL constant kind type" == NULL);
10854             /* Fall through. */
10855           case FFEINFO_kindtypeANY:
10856             return error_mark_node;
10857           }
10858         item = build_real (tree_type, val);
10859       }
10860       break;
10861
10862     case FFEINFO_basictypeCOMPLEX:
10863       {
10864         REAL_VALUE_TYPE real;
10865         REAL_VALUE_TYPE imag;
10866         tree el_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
10867
10868         switch (kt)
10869           {
10870 #if FFETARGET_okCOMPLEX1
10871           case FFEINFO_kindtypeREAL1:
10872             real = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).real);
10873             imag = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).imaginary);
10874             break;
10875 #endif
10876
10877 #if FFETARGET_okCOMPLEX2
10878           case FFEINFO_kindtypeREAL2:
10879             real = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).real);
10880             imag = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).imaginary);
10881             break;
10882 #endif
10883
10884 #if FFETARGET_okCOMPLEX3
10885           case FFEINFO_kindtypeREAL3:
10886             real = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).real);
10887             imag = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).imaginary);
10888             break;
10889 #endif
10890
10891 #if FFETARGET_okCOMPLEX4
10892           case FFEINFO_kindtypeREAL4:
10893             real = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).real);
10894             imag = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).imaginary);
10895             break;
10896 #endif
10897
10898           default:
10899             assert ("bad REAL constant kind type" == NULL);
10900             /* Fall through. */
10901           case FFEINFO_kindtypeANY:
10902             return error_mark_node;
10903           }
10904         item = ffecom_build_complex_constant_ (tree_type,
10905                                                build_real (el_type, real),
10906                                                build_real (el_type, imag));
10907       }
10908       break;
10909
10910     case FFEINFO_basictypeCHARACTER:
10911       {                         /* Happens only in DATA and similar contexts. */
10912         ffetargetCharacter1 val;
10913
10914         switch (kt)
10915           {
10916 #if FFETARGET_okCHARACTER1
10917           case FFEINFO_kindtypeLOGICAL1:
10918             val = ffebld_cu_val_character1 (*cu);
10919             break;
10920 #endif
10921
10922           default:
10923             assert ("bad CHARACTER constant kind type" == NULL);
10924             /* Fall through. */
10925           case FFEINFO_kindtypeANY:
10926             return error_mark_node;
10927           }
10928         item = build_string (ffetarget_length_character1 (val),
10929                              ffetarget_text_character1 (val));
10930         TREE_TYPE (item)
10931           = build_type_variant (build_array_type (char_type_node,
10932                                                   build_range_type
10933                                                   (integer_type_node,
10934                                                    integer_one_node,
10935                                                    build_int_2
10936                                                 (ffetarget_length_character1
10937                                                  (val), 0))),
10938                                 1, 0);
10939       }
10940       break;
10941
10942     case FFEINFO_basictypeHOLLERITH:
10943       {
10944         ffetargetHollerith h;
10945
10946         h = ffebld_cu_val_hollerith (*cu);
10947
10948         /* If not at least as wide as default INTEGER, widen it.  */
10949         if (h.length >= FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE)
10950           item = build_string (h.length, h.text);
10951         else
10952           {
10953             char str[FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE];
10954
10955             memcpy (str, h.text, h.length);
10956             memset (&str[h.length], ' ',
10957                     FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE
10958                     - h.length);
10959             item = build_string (FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE,
10960                                  str);
10961           }
10962         TREE_TYPE (item)
10963           = build_type_variant (build_array_type (char_type_node,
10964                                                   build_range_type
10965                                                   (integer_type_node,
10966                                                    integer_one_node,
10967                                                    build_int_2
10968                                                    (h.length, 0))),
10969                                 1, 0);
10970       }
10971       break;
10972
10973     case FFEINFO_basictypeTYPELESS:
10974       {
10975         ffetargetInteger1 ival;
10976         ffetargetTypeless tless;
10977         ffebad error;
10978
10979         tless = ffebld_cu_val_typeless (*cu);
10980         error = ffetarget_convert_integer1_typeless (&ival, tless);
10981         assert (error == FFEBAD);
10982
10983         item = build_int_2 ((int) ival, 0);
10984       }
10985       break;
10986
10987     default:
10988       assert ("not yet on constant type" == NULL);
10989       /* Fall through. */
10990     case FFEINFO_basictypeANY:
10991       return error_mark_node;
10992     }
10993
10994   TREE_CONSTANT (item) = 1;
10995
10996   return item;
10997 }
10998
10999 #endif
11000
11001 /* Transform expression into constant tree.
11002
11003    If the expression can be transformed into a tree that is constant,
11004    that is done, and the tree returned.  Else NULL_TREE is returned.
11005
11006    That way, a caller can attempt to provide compile-time initialization
11007    of a variable and, if that fails, *then* choose to start a new block
11008    and resort to using temporaries, as appropriate.  */
11009
11010 tree
11011 ffecom_const_expr (ffebld expr)
11012 {
11013   if (! expr)
11014     return integer_zero_node;
11015
11016   if (ffebld_op (expr) == FFEBLD_opANY)
11017     return error_mark_node;
11018
11019   if (ffebld_arity (expr) == 0
11020       && (ffebld_op (expr) != FFEBLD_opSYMTER
11021 #if NEWCOMMON
11022           /* ~~Enable once common/equivalence is handled properly?  */
11023           || ffebld_where (expr) == FFEINFO_whereCOMMON
11024 #endif
11025           || ffebld_where (expr) == FFEINFO_whereGLOBAL
11026           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
11027     {
11028       tree t;
11029
11030       t = ffecom_expr (expr);
11031       assert (TREE_CONSTANT (t));
11032       return t;
11033     }
11034
11035   return NULL_TREE;
11036 }
11037
11038 /* Handy way to make a field in a struct/union.  */
11039
11040 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11041 tree
11042 ffecom_decl_field (tree context, tree prevfield,
11043                    const char *name, tree type)
11044 {
11045   tree field;
11046
11047   field = build_decl (FIELD_DECL, get_identifier (name), type);
11048   DECL_CONTEXT (field) = context;
11049   DECL_ALIGN (field) = 0;
11050   DECL_USER_ALIGN (field) = 0;
11051   if (prevfield != NULL_TREE)
11052     TREE_CHAIN (prevfield) = field;
11053
11054   return field;
11055 }
11056
11057 #endif
11058
11059 void
11060 ffecom_close_include (FILE *f)
11061 {
11062 #if FFECOM_GCC_INCLUDE
11063   ffecom_close_include_ (f);
11064 #endif
11065 }
11066
11067 int
11068 ffecom_decode_include_option (char *spec)
11069 {
11070 #if FFECOM_GCC_INCLUDE
11071   return ffecom_decode_include_option_ (spec);
11072 #else
11073   return 1;
11074 #endif
11075 }
11076
11077 /* End a compound statement (block).  */
11078
11079 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11080 tree
11081 ffecom_end_compstmt (void)
11082 {
11083   return bison_rule_compstmt_ ();
11084 }
11085 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
11086
11087 /* ffecom_end_transition -- Perform end transition on all symbols
11088
11089    ffecom_end_transition();
11090
11091    Calls ffecom_sym_end_transition for each global and local symbol.  */
11092
11093 void
11094 ffecom_end_transition ()
11095 {
11096 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11097   ffebld item;
11098 #endif
11099
11100   if (ffe_is_ffedebug ())
11101     fprintf (dmpout, "; end_stmt_transition\n");
11102
11103 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11104   ffecom_list_blockdata_ = NULL;
11105   ffecom_list_common_ = NULL;
11106 #endif
11107
11108   ffesymbol_drive (ffecom_sym_end_transition);
11109   if (ffe_is_ffedebug ())
11110     {
11111       ffestorag_report ();
11112 #if FFECOM_targetCURRENT == FFECOM_targetFFE
11113       ffesymbol_report_all ();
11114 #endif
11115     }
11116
11117 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11118   ffecom_start_progunit_ ();
11119
11120   for (item = ffecom_list_blockdata_;
11121        item != NULL;
11122        item = ffebld_trail (item))
11123     {
11124       ffebld callee;
11125       ffesymbol s;
11126       tree dt;
11127       tree t;
11128       tree var;
11129       int yes;
11130       static int number = 0;
11131
11132       callee = ffebld_head (item);
11133       s = ffebld_symter (callee);
11134       t = ffesymbol_hook (s).decl_tree;
11135       if (t == NULL_TREE)
11136         {
11137           s = ffecom_sym_transform_ (s);
11138           t = ffesymbol_hook (s).decl_tree;
11139         }
11140
11141       yes = suspend_momentary ();
11142
11143       dt = build_pointer_type (TREE_TYPE (t));
11144
11145       var = build_decl (VAR_DECL,
11146                         ffecom_get_invented_identifier ("__g77_forceload_%d",
11147                                                         number++),
11148                         dt);
11149       DECL_EXTERNAL (var) = 0;
11150       TREE_STATIC (var) = 1;
11151       TREE_PUBLIC (var) = 0;
11152       DECL_INITIAL (var) = error_mark_node;
11153       TREE_USED (var) = 1;
11154
11155       var = start_decl (var, FALSE);
11156
11157       t = ffecom_1 (ADDR_EXPR, dt, t);
11158
11159       finish_decl (var, t, FALSE);
11160
11161       resume_momentary (yes);
11162     }
11163
11164   /* This handles any COMMON areas that weren't referenced but have, for
11165      example, important initial data.  */
11166
11167   for (item = ffecom_list_common_;
11168        item != NULL;
11169        item = ffebld_trail (item))
11170     ffecom_transform_common_ (ffebld_symter (ffebld_head (item)));
11171
11172   ffecom_list_common_ = NULL;
11173 #endif
11174 }
11175
11176 /* ffecom_exec_transition -- Perform exec transition on all symbols
11177
11178    ffecom_exec_transition();
11179
11180    Calls ffecom_sym_exec_transition for each global and local symbol.
11181    Make sure error updating not inhibited.  */
11182
11183 void
11184 ffecom_exec_transition ()
11185 {
11186   bool inhibited;
11187
11188   if (ffe_is_ffedebug ())
11189     fprintf (dmpout, "; exec_stmt_transition\n");
11190
11191   inhibited = ffebad_inhibit ();
11192   ffebad_set_inhibit (FALSE);
11193
11194   ffesymbol_drive (ffecom_sym_exec_transition); /* Don't retract! */
11195   ffeequiv_exec_transition ();  /* Handle all pending EQUIVALENCEs. */
11196   if (ffe_is_ffedebug ())
11197     {
11198       ffestorag_report ();
11199 #if FFECOM_targetCURRENT == FFECOM_targetFFE
11200       ffesymbol_report_all ();
11201 #endif
11202     }
11203
11204   if (inhibited)
11205     ffebad_set_inhibit (TRUE);
11206 }
11207
11208 /* Handle assignment statement.
11209
11210    Convert dest and source using ffecom_expr, then join them
11211    with an ASSIGN op and pass the whole thing to expand_expr_stmt.  */
11212
11213 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11214 void
11215 ffecom_expand_let_stmt (ffebld dest, ffebld source)
11216 {
11217   tree dest_tree;
11218   tree dest_length;
11219   tree source_tree;
11220   tree expr_tree;
11221
11222   if (ffeinfo_basictype (ffebld_info (dest)) != FFEINFO_basictypeCHARACTER)
11223     {
11224       bool dest_used;
11225       tree assign_temp;
11226
11227       /* This attempts to replicate the test below, but must not be
11228          true when the test below is false.  (Always err on the side
11229          of creating unused temporaries, to avoid ICEs.)  */
11230       if (ffebld_op (dest) != FFEBLD_opSYMTER
11231           || ((dest_tree = ffesymbol_hook (ffebld_symter (dest)).decl_tree)
11232               && (TREE_CODE (dest_tree) != VAR_DECL
11233                   || TREE_ADDRESSABLE (dest_tree))))
11234         {
11235           ffecom_prepare_expr_ (source, dest);
11236           dest_used = TRUE;
11237         }
11238       else
11239         {
11240           ffecom_prepare_expr_ (source, NULL);
11241           dest_used = FALSE;
11242         }
11243
11244       ffecom_prepare_expr_w (NULL_TREE, dest);
11245
11246       /* For COMPLEX assignment like C1=C2, if partial overlap is possible,
11247          create a temporary through which the assignment is to take place,
11248          since MODIFY_EXPR doesn't handle partial overlap properly.  */
11249       if (ffebld_basictype (dest) == FFEINFO_basictypeCOMPLEX
11250           && ffecom_possible_partial_overlap_ (dest, source))
11251         {
11252           assign_temp = ffecom_make_tempvar ("complex_let",
11253                                              ffecom_tree_type
11254                                              [ffebld_basictype (dest)]
11255                                              [ffebld_kindtype (dest)],
11256                                              FFETARGET_charactersizeNONE,
11257                                              -1);
11258         }
11259       else
11260         assign_temp = NULL_TREE;
11261
11262       ffecom_prepare_end ();
11263
11264       dest_tree = ffecom_expr_w (NULL_TREE, dest);
11265       if (dest_tree == error_mark_node)
11266         return;
11267
11268       if ((TREE_CODE (dest_tree) != VAR_DECL)
11269           || TREE_ADDRESSABLE (dest_tree))
11270         source_tree = ffecom_expr_ (source, dest_tree, dest, &dest_used,
11271                                     FALSE, FALSE);
11272       else
11273         {
11274           assert (! dest_used);
11275           dest_used = FALSE;
11276           source_tree = ffecom_expr (source);
11277         }
11278       if (source_tree == error_mark_node)
11279         return;
11280
11281       if (dest_used)
11282         expr_tree = source_tree;
11283       else if (assign_temp)
11284         {
11285 #ifdef MOVE_EXPR
11286           /* The back end understands a conceptual move (evaluate source;
11287              store into dest), so use that, in case it can determine
11288              that it is going to use, say, two registers as temporaries
11289              anyway.  So don't use the temp (and someday avoid generating
11290              it, once this code starts triggering regularly).  */
11291           expr_tree = ffecom_2s (MOVE_EXPR, void_type_node,
11292                                  dest_tree,
11293                                  source_tree);
11294 #else
11295           expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11296                                  assign_temp,
11297                                  source_tree);
11298           expand_expr_stmt (expr_tree);
11299           expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11300                                  dest_tree,
11301                                  assign_temp);
11302 #endif
11303         }
11304       else
11305         expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11306                                dest_tree,
11307                                source_tree);
11308
11309       expand_expr_stmt (expr_tree);
11310       return;
11311     }
11312
11313   ffecom_prepare_let_char_ (ffebld_size_known (dest), source);
11314   ffecom_prepare_expr_w (NULL_TREE, dest);
11315
11316   ffecom_prepare_end ();
11317
11318   ffecom_char_args_ (&dest_tree, &dest_length, dest);
11319   ffecom_let_char_ (dest_tree, dest_length, ffebld_size_known (dest),
11320                     source);
11321 }
11322
11323 #endif
11324 /* ffecom_expr -- Transform expr into gcc tree
11325
11326    tree t;
11327    ffebld expr;  // FFE expression.
11328    tree = ffecom_expr(expr);
11329
11330    Recursive descent on expr while making corresponding tree nodes and
11331    attaching type info and such.  */
11332
11333 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11334 tree
11335 ffecom_expr (ffebld expr)
11336 {
11337   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, FALSE, FALSE);
11338 }
11339
11340 #endif
11341 /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT.  */
11342
11343 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11344 tree
11345 ffecom_expr_assign (ffebld expr)
11346 {
11347   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
11348 }
11349
11350 #endif
11351 /* Like ffecom_expr_rw, but return tree usable for ASSIGN.  */
11352
11353 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11354 tree
11355 ffecom_expr_assign_w (ffebld expr)
11356 {
11357   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
11358 }
11359
11360 #endif
11361 /* Transform expr for use as into read/write tree and stabilize the
11362    reference.  Not for use on CHARACTER expressions.
11363
11364    Recursive descent on expr while making corresponding tree nodes and
11365    attaching type info and such.  */
11366
11367 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11368 tree
11369 ffecom_expr_rw (tree type, ffebld expr)
11370 {
11371   assert (expr != NULL);
11372   /* Different target types not yet supported.  */
11373   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
11374
11375   return stabilize_reference (ffecom_expr (expr));
11376 }
11377
11378 #endif
11379 /* Transform expr for use as into write tree and stabilize the
11380    reference.  Not for use on CHARACTER expressions.
11381
11382    Recursive descent on expr while making corresponding tree nodes and
11383    attaching type info and such.  */
11384
11385 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11386 tree
11387 ffecom_expr_w (tree type, ffebld expr)
11388 {
11389   assert (expr != NULL);
11390   /* Different target types not yet supported.  */
11391   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
11392
11393   return stabilize_reference (ffecom_expr (expr));
11394 }
11395
11396 #endif
11397 /* Do global stuff.  */
11398
11399 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11400 void
11401 ffecom_finish_compile ()
11402 {
11403   assert (ffecom_outer_function_decl_ == NULL_TREE);
11404   assert (current_function_decl == NULL_TREE);
11405
11406   ffeglobal_drive (ffecom_finish_global_);
11407 }
11408
11409 #endif
11410 /* Public entry point for front end to access finish_decl.  */
11411
11412 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11413 void
11414 ffecom_finish_decl (tree decl, tree init, bool is_top_level)
11415 {
11416   assert (!is_top_level);
11417   finish_decl (decl, init, FALSE);
11418 }
11419
11420 #endif
11421 /* Finish a program unit.  */
11422
11423 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11424 void
11425 ffecom_finish_progunit ()
11426 {
11427   ffecom_end_compstmt ();
11428
11429   ffecom_previous_function_decl_ = current_function_decl;
11430   ffecom_which_entrypoint_decl_ = NULL_TREE;
11431
11432   finish_function (0);
11433 }
11434
11435 #endif
11436
11437 /* Wrapper for get_identifier.  pattern is sprintf-like.  */
11438
11439 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11440 tree
11441 ffecom_get_invented_identifier (const char *pattern, ...)
11442 {
11443   tree decl;
11444   char *nam;
11445   va_list ap;
11446
11447   va_start (ap, pattern);
11448   if (vasprintf (&nam, pattern, ap) == 0)
11449     abort ();
11450   va_end (ap);
11451   decl = get_identifier (nam);
11452   free (nam);
11453   IDENTIFIER_INVENTED (decl) = 1;
11454   return decl;
11455 }
11456
11457 ffeinfoBasictype
11458 ffecom_gfrt_basictype (ffecomGfrt gfrt)
11459 {
11460   assert (gfrt < FFECOM_gfrt);
11461
11462   switch (ffecom_gfrt_type_[gfrt])
11463     {
11464     case FFECOM_rttypeVOID_:
11465     case FFECOM_rttypeVOIDSTAR_:
11466       return FFEINFO_basictypeNONE;
11467
11468     case FFECOM_rttypeFTNINT_:
11469       return FFEINFO_basictypeINTEGER;
11470
11471     case FFECOM_rttypeINTEGER_:
11472       return FFEINFO_basictypeINTEGER;
11473
11474     case FFECOM_rttypeLONGINT_:
11475       return FFEINFO_basictypeINTEGER;
11476
11477     case FFECOM_rttypeLOGICAL_:
11478       return FFEINFO_basictypeLOGICAL;
11479
11480     case FFECOM_rttypeREAL_F2C_:
11481     case FFECOM_rttypeREAL_GNU_:
11482       return FFEINFO_basictypeREAL;
11483
11484     case FFECOM_rttypeCOMPLEX_F2C_:
11485     case FFECOM_rttypeCOMPLEX_GNU_:
11486       return FFEINFO_basictypeCOMPLEX;
11487
11488     case FFECOM_rttypeDOUBLE_:
11489     case FFECOM_rttypeDOUBLEREAL_:
11490       return FFEINFO_basictypeREAL;
11491
11492     case FFECOM_rttypeDBLCMPLX_F2C_:
11493     case FFECOM_rttypeDBLCMPLX_GNU_:
11494       return FFEINFO_basictypeCOMPLEX;
11495
11496     case FFECOM_rttypeCHARACTER_:
11497       return FFEINFO_basictypeCHARACTER;
11498
11499     default:
11500       return FFEINFO_basictypeANY;
11501     }
11502 }
11503
11504 ffeinfoKindtype
11505 ffecom_gfrt_kindtype (ffecomGfrt gfrt)
11506 {
11507   assert (gfrt < FFECOM_gfrt);
11508
11509   switch (ffecom_gfrt_type_[gfrt])
11510     {
11511     case FFECOM_rttypeVOID_:
11512     case FFECOM_rttypeVOIDSTAR_:
11513       return FFEINFO_kindtypeNONE;
11514
11515     case FFECOM_rttypeFTNINT_:
11516       return FFEINFO_kindtypeINTEGER1;
11517
11518     case FFECOM_rttypeINTEGER_:
11519       return FFEINFO_kindtypeINTEGER1;
11520
11521     case FFECOM_rttypeLONGINT_:
11522       return FFEINFO_kindtypeINTEGER4;
11523
11524     case FFECOM_rttypeLOGICAL_:
11525       return FFEINFO_kindtypeLOGICAL1;
11526
11527     case FFECOM_rttypeREAL_F2C_:
11528     case FFECOM_rttypeREAL_GNU_:
11529       return FFEINFO_kindtypeREAL1;
11530
11531     case FFECOM_rttypeCOMPLEX_F2C_:
11532     case FFECOM_rttypeCOMPLEX_GNU_:
11533       return FFEINFO_kindtypeREAL1;
11534
11535     case FFECOM_rttypeDOUBLE_:
11536     case FFECOM_rttypeDOUBLEREAL_:
11537       return FFEINFO_kindtypeREAL2;
11538
11539     case FFECOM_rttypeDBLCMPLX_F2C_:
11540     case FFECOM_rttypeDBLCMPLX_GNU_:
11541       return FFEINFO_kindtypeREAL2;
11542
11543     case FFECOM_rttypeCHARACTER_:
11544       return FFEINFO_kindtypeCHARACTER1;
11545
11546     default:
11547       return FFEINFO_kindtypeANY;
11548     }
11549 }
11550
11551 void
11552 ffecom_init_0 ()
11553 {
11554   tree endlink;
11555   int i;
11556   int j;
11557   tree t;
11558   tree field;
11559   ffetype type;
11560   ffetype base_type;
11561   tree double_ftype_double;
11562   tree float_ftype_float;
11563   tree ldouble_ftype_ldouble;
11564   tree ffecom_tree_ptr_to_fun_type_void;
11565
11566   /* This block of code comes from the now-obsolete cktyps.c.  It checks
11567      whether the compiler environment is buggy in known ways, some of which
11568      would, if not explicitly checked here, result in subtle bugs in g77.  */
11569
11570   if (ffe_is_do_internal_checks ())
11571     {
11572       static char names[][12]
11573         =
11574       {"bar", "bletch", "foo", "foobar"};
11575       char *name;
11576       unsigned long ul;
11577       double fl;
11578
11579       name = bsearch ("foo", &names[0], ARRAY_SIZE (names), sizeof (names[0]),
11580                       (int (*)(const void *, const void *)) strcmp);
11581       if (name != (char *) &names[2])
11582         {
11583           assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
11584                   == NULL);
11585           abort ();
11586         }
11587
11588       ul = strtoul ("123456789", NULL, 10);
11589       if (ul != 123456789L)
11590         {
11591           assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\
11592  in proj.h" == NULL);
11593           abort ();
11594         }
11595
11596       fl = atof ("56.789");
11597       if ((fl < 56.788) || (fl > 56.79))
11598         {
11599           assert ("atof not type double, fix your #include <stdio.h>"
11600                   == NULL);
11601           abort ();
11602         }
11603     }
11604
11605 #if FFECOM_GCC_INCLUDE
11606   ffecom_initialize_char_syntax_ ();
11607 #endif
11608
11609   ffecom_outer_function_decl_ = NULL_TREE;
11610   current_function_decl = NULL_TREE;
11611   named_labels = NULL_TREE;
11612   current_binding_level = NULL_BINDING_LEVEL;
11613   free_binding_level = NULL_BINDING_LEVEL;
11614   /* Make the binding_level structure for global names.  */
11615   pushlevel (0);
11616   global_binding_level = current_binding_level;
11617   current_binding_level->prep_state = 2;
11618
11619   build_common_tree_nodes (1);
11620
11621   /* Define `int' and `char' first so that dbx will output them first.  */
11622   pushdecl (build_decl (TYPE_DECL, get_identifier ("int"),
11623                         integer_type_node));
11624   pushdecl (build_decl (TYPE_DECL, get_identifier ("char"),
11625                         char_type_node));
11626   pushdecl (build_decl (TYPE_DECL, get_identifier ("long int"),
11627                         long_integer_type_node));
11628   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"),
11629                         unsigned_type_node));
11630   pushdecl (build_decl (TYPE_DECL, get_identifier ("long unsigned int"),
11631                         long_unsigned_type_node));
11632   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long int"),
11633                         long_long_integer_type_node));
11634   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long unsigned int"),
11635                         long_long_unsigned_type_node));
11636   pushdecl (build_decl (TYPE_DECL, get_identifier ("short int"),
11637                         short_integer_type_node));
11638   pushdecl (build_decl (TYPE_DECL, get_identifier ("short unsigned int"),
11639                         short_unsigned_type_node));
11640
11641   /* Set the sizetype before we make other types.  This *should* be the
11642      first type we create.  */
11643
11644   set_sizetype
11645     (TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE))));
11646   ffecom_typesize_pointer_
11647     = TREE_INT_CST_LOW (TYPE_SIZE (sizetype)) / BITS_PER_UNIT;
11648
11649   build_common_tree_nodes_2 (0);
11650
11651   /* Define both `signed char' and `unsigned char'.  */
11652   pushdecl (build_decl (TYPE_DECL, get_identifier ("signed char"),
11653                         signed_char_type_node));
11654
11655   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"),
11656                         unsigned_char_type_node));
11657
11658   pushdecl (build_decl (TYPE_DECL, get_identifier ("float"),
11659                         float_type_node));
11660   pushdecl (build_decl (TYPE_DECL, get_identifier ("double"),
11661                         double_type_node));
11662   pushdecl (build_decl (TYPE_DECL, get_identifier ("long double"),
11663                         long_double_type_node));
11664
11665   /* For now, override what build_common_tree_nodes has done.  */
11666   complex_integer_type_node = ffecom_make_complex_type_ (integer_type_node);
11667   complex_float_type_node = ffecom_make_complex_type_ (float_type_node);
11668   complex_double_type_node = ffecom_make_complex_type_ (double_type_node);
11669   complex_long_double_type_node
11670     = ffecom_make_complex_type_ (long_double_type_node);
11671
11672   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex int"),
11673                         complex_integer_type_node));
11674   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex float"),
11675                         complex_float_type_node));
11676   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex double"),
11677                         complex_double_type_node));
11678   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex long double"),
11679                         complex_long_double_type_node));
11680
11681   pushdecl (build_decl (TYPE_DECL, get_identifier ("void"),
11682                         void_type_node));
11683   /* We are not going to have real types in C with less than byte alignment,
11684      so we might as well not have any types that claim to have it.  */
11685   TYPE_ALIGN (void_type_node) = BITS_PER_UNIT;
11686   TYPE_USER_ALIGN (void_type_node) = 0;
11687
11688   string_type_node = build_pointer_type (char_type_node);
11689
11690   ffecom_tree_fun_type_void
11691     = build_function_type (void_type_node, NULL_TREE);
11692
11693   ffecom_tree_ptr_to_fun_type_void
11694     = build_pointer_type (ffecom_tree_fun_type_void);
11695
11696   endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
11697
11698   float_ftype_float
11699     = build_function_type (float_type_node,
11700                            tree_cons (NULL_TREE, float_type_node, endlink));
11701
11702   double_ftype_double
11703     = build_function_type (double_type_node,
11704                            tree_cons (NULL_TREE, double_type_node, endlink));
11705
11706   ldouble_ftype_ldouble
11707     = build_function_type (long_double_type_node,
11708                            tree_cons (NULL_TREE, long_double_type_node,
11709                                       endlink));
11710
11711   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11712     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11713       {
11714         ffecom_tree_type[i][j] = NULL_TREE;
11715         ffecom_tree_fun_type[i][j] = NULL_TREE;
11716         ffecom_tree_ptr_to_fun_type[i][j] = NULL_TREE;
11717         ffecom_f2c_typecode_[i][j] = -1;
11718       }
11719
11720   /* Set up standard g77 types.  Note that INTEGER and LOGICAL are set
11721      to size FLOAT_TYPE_SIZE because they have to be the same size as
11722      REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
11723      Compiler options and other such stuff that change the ways these
11724      types are set should not affect this particular setup.  */
11725
11726   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1]
11727     = t = make_signed_type (FLOAT_TYPE_SIZE);
11728   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer"),
11729                         t));
11730   type = ffetype_new ();
11731   base_type = type;
11732   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER1,
11733                     type);
11734   ffetype_set_ams (type,
11735                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11736                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11737   ffetype_set_star (base_type,
11738                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11739                     type);
11740   ffetype_set_kind (base_type, 1, type);
11741   ffecom_typesize_integer1_ = ffetype_size (type);
11742   assert (ffetype_size (type) == sizeof (ffetargetInteger1));
11743
11744   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER1]
11745     = t = make_unsigned_type (FLOAT_TYPE_SIZE); /* HOLLERITH means unsigned. */
11746   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned"),
11747                         t));
11748
11749   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER2]
11750     = t = make_signed_type (CHAR_TYPE_SIZE);
11751   pushdecl (build_decl (TYPE_DECL, get_identifier ("byte"),
11752                         t));
11753   type = ffetype_new ();
11754   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER2,
11755                     type);
11756   ffetype_set_ams (type,
11757                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11758                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11759   ffetype_set_star (base_type,
11760                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11761                     type);
11762   ffetype_set_kind (base_type, 3, type);
11763   assert (ffetype_size (type) == sizeof (ffetargetInteger2));
11764
11765   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER2]
11766     = t = make_unsigned_type (CHAR_TYPE_SIZE);
11767   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned byte"),
11768                         t));
11769
11770   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER3]
11771     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11772   pushdecl (build_decl (TYPE_DECL, get_identifier ("word"),
11773                         t));
11774   type = ffetype_new ();
11775   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER3,
11776                     type);
11777   ffetype_set_ams (type,
11778                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11779                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11780   ffetype_set_star (base_type,
11781                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11782                     type);
11783   ffetype_set_kind (base_type, 6, type);
11784   assert (ffetype_size (type) == sizeof (ffetargetInteger3));
11785
11786   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER3]
11787     = t = make_unsigned_type (CHAR_TYPE_SIZE * 2);
11788   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned word"),
11789                         t));
11790
11791   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER4]
11792     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11793   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer4"),
11794                         t));
11795   type = ffetype_new ();
11796   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER4,
11797                     type);
11798   ffetype_set_ams (type,
11799                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11800                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11801   ffetype_set_star (base_type,
11802                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11803                     type);
11804   ffetype_set_kind (base_type, 2, type);
11805   assert (ffetype_size (type) == sizeof (ffetargetInteger4));
11806
11807   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER4]
11808     = t = make_unsigned_type (FLOAT_TYPE_SIZE * 2);
11809   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned4"),
11810                         t));
11811
11812 #if 0
11813   if (ffe_is_do_internal_checks ()
11814       && LONG_TYPE_SIZE != FLOAT_TYPE_SIZE
11815       && LONG_TYPE_SIZE != CHAR_TYPE_SIZE
11816       && LONG_TYPE_SIZE != SHORT_TYPE_SIZE
11817       && LONG_TYPE_SIZE != LONG_LONG_TYPE_SIZE)
11818     {
11819       fprintf (stderr, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n",
11820                LONG_TYPE_SIZE);
11821     }
11822 #endif
11823
11824   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL1]
11825     = t = make_signed_type (FLOAT_TYPE_SIZE);
11826   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical"),
11827                         t));
11828   type = ffetype_new ();
11829   base_type = type;
11830   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL1,
11831                     type);
11832   ffetype_set_ams (type,
11833                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11834                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11835   ffetype_set_star (base_type,
11836                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11837                     type);
11838   ffetype_set_kind (base_type, 1, type);
11839   assert (ffetype_size (type) == sizeof (ffetargetLogical1));
11840
11841   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL2]
11842     = t = make_signed_type (CHAR_TYPE_SIZE);
11843   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical2"),
11844                         t));
11845   type = ffetype_new ();
11846   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL2,
11847                     type);
11848   ffetype_set_ams (type,
11849                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11850                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11851   ffetype_set_star (base_type,
11852                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11853                     type);
11854   ffetype_set_kind (base_type, 3, type);
11855   assert (ffetype_size (type) == sizeof (ffetargetLogical2));
11856
11857   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL3]
11858     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11859   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical3"),
11860                         t));
11861   type = ffetype_new ();
11862   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL3,
11863                     type);
11864   ffetype_set_ams (type,
11865                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11866                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11867   ffetype_set_star (base_type,
11868                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11869                     type);
11870   ffetype_set_kind (base_type, 6, type);
11871   assert (ffetype_size (type) == sizeof (ffetargetLogical3));
11872
11873   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL4]
11874     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11875   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical4"),
11876                         t));
11877   type = ffetype_new ();
11878   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL4,
11879                     type);
11880   ffetype_set_ams (type,
11881                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11882                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11883   ffetype_set_star (base_type,
11884                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11885                     type);
11886   ffetype_set_kind (base_type, 2, type);
11887   assert (ffetype_size (type) == sizeof (ffetargetLogical4));
11888
11889   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11890     = t = make_node (REAL_TYPE);
11891   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE;
11892   pushdecl (build_decl (TYPE_DECL, get_identifier ("real"),
11893                         t));
11894   layout_type (t);
11895   type = ffetype_new ();
11896   base_type = type;
11897   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL1,
11898                     type);
11899   ffetype_set_ams (type,
11900                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11901                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11902   ffetype_set_star (base_type,
11903                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11904                     type);
11905   ffetype_set_kind (base_type, 1, type);
11906   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11907     = FFETARGET_f2cTYREAL;
11908   assert (ffetype_size (type) == sizeof (ffetargetReal1));
11909
11910   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREALDOUBLE]
11911     = t = make_node (REAL_TYPE);
11912   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE * 2;     /* Always twice REAL. */
11913   pushdecl (build_decl (TYPE_DECL, get_identifier ("double precision"),
11914                         t));
11915   layout_type (t);
11916   type = ffetype_new ();
11917   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
11918                     type);
11919   ffetype_set_ams (type,
11920                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11921                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11922   ffetype_set_star (base_type,
11923                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11924                     type);
11925   ffetype_set_kind (base_type, 2, type);
11926   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]
11927     = FFETARGET_f2cTYDREAL;
11928   assert (ffetype_size (type) == sizeof (ffetargetReal2));
11929
11930   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11931     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]);
11932   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex"),
11933                         t));
11934   type = ffetype_new ();
11935   base_type = type;
11936   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL1,
11937                     type);
11938   ffetype_set_ams (type,
11939                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11940                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11941   ffetype_set_star (base_type,
11942                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11943                     type);
11944   ffetype_set_kind (base_type, 1, type);
11945   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11946     = FFETARGET_f2cTYCOMPLEX;
11947   assert (ffetype_size (type) == sizeof (ffetargetComplex1));
11948
11949   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREALDOUBLE]
11950     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]);
11951   pushdecl (build_decl (TYPE_DECL, get_identifier ("double complex"),
11952                         t));
11953   type = ffetype_new ();
11954   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREALDOUBLE,
11955                     type);
11956   ffetype_set_ams (type,
11957                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11958                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11959   ffetype_set_star (base_type,
11960                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11961                     type);
11962   ffetype_set_kind (base_type, 2,
11963                     type);
11964   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL2]
11965     = FFETARGET_f2cTYDCOMPLEX;
11966   assert (ffetype_size (type) == sizeof (ffetargetComplex2));
11967
11968   /* Make function and ptr-to-function types for non-CHARACTER types. */
11969
11970   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11971     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11972       {
11973         if ((t = ffecom_tree_type[i][j]) != NULL_TREE)
11974           {
11975             if (i == FFEINFO_basictypeINTEGER)
11976               {
11977                 /* Figure out the smallest INTEGER type that can hold
11978                    a pointer on this machine. */
11979                 if (GET_MODE_SIZE (TYPE_MODE (t))
11980                     >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
11981                   {
11982                     if ((ffecom_pointer_kind_ == FFEINFO_kindtypeNONE)
11983                         || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type[i][ffecom_pointer_kind_]))
11984                             > GET_MODE_SIZE (TYPE_MODE (t))))
11985                       ffecom_pointer_kind_ = j;
11986                   }
11987               }
11988             else if (i == FFEINFO_basictypeCOMPLEX)
11989               t = void_type_node;
11990             /* For f2c compatibility, REAL functions are really
11991                implemented as DOUBLE PRECISION.  */
11992             else if ((i == FFEINFO_basictypeREAL)
11993                      && (j == FFEINFO_kindtypeREAL1))
11994               t = ffecom_tree_type
11995                 [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2];
11996
11997             t = ffecom_tree_fun_type[i][j] = build_function_type (t,
11998                                                                   NULL_TREE);
11999             ffecom_tree_ptr_to_fun_type[i][j] = build_pointer_type (t);
12000           }
12001       }
12002
12003   /* Set up pointer types.  */
12004
12005   if (ffecom_pointer_kind_ == FFEINFO_basictypeNONE)
12006     fatal ("no INTEGER type can hold a pointer on this configuration");
12007   else if (0 && ffe_is_do_internal_checks ())
12008     fprintf (stderr, "Pointer type kt=%d\n", ffecom_pointer_kind_);
12009   ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER,
12010                                   FFEINFO_kindtypeINTEGERDEFAULT),
12011                     7,
12012                     ffeinfo_type (FFEINFO_basictypeINTEGER,
12013                                   ffecom_pointer_kind_));
12014
12015   if (ffe_is_ugly_assign ())
12016     ffecom_label_kind_ = ffecom_pointer_kind_;  /* Require ASSIGN etc to this. */
12017   else
12018     ffecom_label_kind_ = FFEINFO_kindtypeINTEGERDEFAULT;
12019   if (0 && ffe_is_do_internal_checks ())
12020     fprintf (stderr, "Label type kt=%d\n", ffecom_label_kind_);
12021
12022   ffecom_integer_type_node
12023     = ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1];
12024   ffecom_integer_zero_node = convert (ffecom_integer_type_node,
12025                                       integer_zero_node);
12026   ffecom_integer_one_node = convert (ffecom_integer_type_node,
12027                                      integer_one_node);
12028
12029   /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
12030      Turns out that by TYLONG, runtime/libI77/lio.h really means
12031      "whatever size an ftnint is".  For consistency and sanity,
12032      com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
12033      all are INTEGER, which we also make out of whatever back-end
12034      integer type is FLOAT_TYPE_SIZE bits wide.  This change, from
12035      LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
12036      accommodate machines like the Alpha.  Note that this suggests
12037      f2c and libf2c are missing a distinction perhaps needed on
12038      some machines between "int" and "long int".  -- burley 0.5.5 950215 */
12039
12040   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, FLOAT_TYPE_SIZE,
12041                             FFETARGET_f2cTYLONG);
12042   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, SHORT_TYPE_SIZE,
12043                             FFETARGET_f2cTYSHORT);
12044   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, CHAR_TYPE_SIZE,
12045                             FFETARGET_f2cTYINT1);
12046   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, LONG_LONG_TYPE_SIZE,
12047                             FFETARGET_f2cTYQUAD);
12048   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, FLOAT_TYPE_SIZE,
12049                             FFETARGET_f2cTYLOGICAL);
12050   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, SHORT_TYPE_SIZE,
12051                             FFETARGET_f2cTYLOGICAL2);
12052   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, CHAR_TYPE_SIZE,
12053                             FFETARGET_f2cTYLOGICAL1);
12054   /* ~~~Not really such a type in libf2c, e.g. I/O support?  */
12055   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, LONG_LONG_TYPE_SIZE,
12056                             FFETARGET_f2cTYQUAD);
12057
12058   /* CHARACTER stuff is all special-cased, so it is not handled in the above
12059      loop.  CHARACTER items are built as arrays of unsigned char.  */
12060
12061   ffecom_tree_type[FFEINFO_basictypeCHARACTER]
12062     [FFEINFO_kindtypeCHARACTER1] = t = char_type_node;
12063   type = ffetype_new ();
12064   base_type = type;
12065   ffeinfo_set_type (FFEINFO_basictypeCHARACTER,
12066                     FFEINFO_kindtypeCHARACTER1,
12067                     type);
12068   ffetype_set_ams (type,
12069                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
12070                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
12071   ffetype_set_kind (base_type, 1, type);
12072   assert (ffetype_size (type)
12073           == sizeof (((ffetargetCharacter1) { 0, NULL }).text[0]));
12074
12075   ffecom_tree_fun_type[FFEINFO_basictypeCHARACTER]
12076     [FFEINFO_kindtypeCHARACTER1] = ffecom_tree_fun_type_void;
12077   ffecom_tree_ptr_to_fun_type[FFEINFO_basictypeCHARACTER]
12078     [FFEINFO_kindtypeCHARACTER1]
12079     = ffecom_tree_ptr_to_fun_type_void;
12080   ffecom_f2c_typecode_[FFEINFO_basictypeCHARACTER][FFEINFO_kindtypeCHARACTER1]
12081     = FFETARGET_f2cTYCHAR;
12082
12083   ffecom_f2c_typecode_[FFEINFO_basictypeANY][FFEINFO_kindtypeANY]
12084     = 0;
12085
12086   /* Make multi-return-value type and fields. */
12087
12088   ffecom_multi_type_node_ = make_node (UNION_TYPE);
12089
12090   field = NULL_TREE;
12091
12092   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
12093     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
12094       {
12095         char name[30];
12096
12097         if (ffecom_tree_type[i][j] == NULL_TREE)
12098           continue;             /* Not supported. */
12099         sprintf (&name[0], "bt_%s_kt_%s",
12100                  ffeinfo_basictype_string ((ffeinfoBasictype) i),
12101                  ffeinfo_kindtype_string ((ffeinfoKindtype) j));
12102         ffecom_multi_fields_[i][j] = build_decl (FIELD_DECL,
12103                                                  get_identifier (name),
12104                                                  ffecom_tree_type[i][j]);
12105         DECL_CONTEXT (ffecom_multi_fields_[i][j])
12106           = ffecom_multi_type_node_;
12107         DECL_ALIGN (ffecom_multi_fields_[i][j]) = 0;
12108         DECL_USER_ALIGN (ffecom_multi_fields_[i][j]) = 0;
12109         TREE_CHAIN (ffecom_multi_fields_[i][j]) = field;
12110         field = ffecom_multi_fields_[i][j];
12111       }
12112
12113   TYPE_FIELDS (ffecom_multi_type_node_) = field;
12114   layout_type (ffecom_multi_type_node_);
12115
12116   /* Subroutines usually return integer because they might have alternate
12117      returns. */
12118
12119   ffecom_tree_subr_type
12120     = build_function_type (integer_type_node, NULL_TREE);
12121   ffecom_tree_ptr_to_subr_type
12122     = build_pointer_type (ffecom_tree_subr_type);
12123   ffecom_tree_blockdata_type
12124     = build_function_type (void_type_node, NULL_TREE);
12125
12126   builtin_function ("__builtin_sqrtf", float_ftype_float,
12127                     BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrtf");
12128   builtin_function ("__builtin_fsqrt", double_ftype_double,
12129                     BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrt");
12130   builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble,
12131                     BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrtl");
12132   builtin_function ("__builtin_sinf", float_ftype_float,
12133                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sinf");
12134   builtin_function ("__builtin_sin", double_ftype_double,
12135                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sin");
12136   builtin_function ("__builtin_sinl", ldouble_ftype_ldouble,
12137                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sinl");
12138   builtin_function ("__builtin_cosf", float_ftype_float,
12139                     BUILT_IN_COS, BUILT_IN_NORMAL, "cosf");
12140   builtin_function ("__builtin_cos", double_ftype_double,
12141                     BUILT_IN_COS, BUILT_IN_NORMAL, "cos");
12142   builtin_function ("__builtin_cosl", ldouble_ftype_ldouble,
12143                     BUILT_IN_COS, BUILT_IN_NORMAL, "cosl");
12144
12145 #if BUILT_FOR_270
12146   pedantic_lvalues = FALSE;
12147 #endif
12148
12149   ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node,
12150                          FFECOM_f2cINTEGER,
12151                          "integer");
12152   ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node,
12153                          FFECOM_f2cADDRESS,
12154                          "address");
12155   ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node,
12156                          FFECOM_f2cREAL,
12157                          "real");
12158   ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node,
12159                          FFECOM_f2cDOUBLEREAL,
12160                          "doublereal");
12161   ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node,
12162                          FFECOM_f2cCOMPLEX,
12163                          "complex");
12164   ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node,
12165                          FFECOM_f2cDOUBLECOMPLEX,
12166                          "doublecomplex");
12167   ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node,
12168                          FFECOM_f2cLONGINT,
12169                          "longint");
12170   ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node,
12171                          FFECOM_f2cLOGICAL,
12172                          "logical");
12173   ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node,
12174                          FFECOM_f2cFLAG,
12175                          "flag");
12176   ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node,
12177                          FFECOM_f2cFTNLEN,
12178                          "ftnlen");
12179   ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node,
12180                          FFECOM_f2cFTNINT,
12181                          "ftnint");
12182
12183   ffecom_f2c_ftnlen_zero_node
12184     = convert (ffecom_f2c_ftnlen_type_node, integer_zero_node);
12185
12186   ffecom_f2c_ftnlen_one_node
12187     = convert (ffecom_f2c_ftnlen_type_node, integer_one_node);
12188
12189   ffecom_f2c_ftnlen_two_node = build_int_2 (2, 0);
12190   TREE_TYPE (ffecom_f2c_ftnlen_two_node) = ffecom_integer_type_node;
12191
12192   ffecom_f2c_ptr_to_ftnlen_type_node
12193     = build_pointer_type (ffecom_f2c_ftnlen_type_node);
12194
12195   ffecom_f2c_ptr_to_ftnint_type_node
12196     = build_pointer_type (ffecom_f2c_ftnint_type_node);
12197
12198   ffecom_f2c_ptr_to_integer_type_node
12199     = build_pointer_type (ffecom_f2c_integer_type_node);
12200
12201   ffecom_f2c_ptr_to_real_type_node
12202     = build_pointer_type (ffecom_f2c_real_type_node);
12203
12204   ffecom_float_zero_ = build_real (float_type_node, dconst0);
12205   ffecom_double_zero_ = build_real (double_type_node, dconst0);
12206   {
12207     REAL_VALUE_TYPE point_5;
12208
12209 #ifdef REAL_ARITHMETIC
12210     REAL_ARITHMETIC (point_5, RDIV_EXPR, dconst1, dconst2);
12211 #else
12212     point_5 = .5;
12213 #endif
12214     ffecom_float_half_ = build_real (float_type_node, point_5);
12215     ffecom_double_half_ = build_real (double_type_node, point_5);
12216   }
12217
12218   /* Do "extern int xargc;".  */
12219
12220   ffecom_tree_xargc_ = build_decl (VAR_DECL,
12221                                    get_identifier ("f__xargc"),
12222                                    integer_type_node);
12223   DECL_EXTERNAL (ffecom_tree_xargc_) = 1;
12224   TREE_STATIC (ffecom_tree_xargc_) = 1;
12225   TREE_PUBLIC (ffecom_tree_xargc_) = 1;
12226   ffecom_tree_xargc_ = start_decl (ffecom_tree_xargc_, FALSE);
12227   finish_decl (ffecom_tree_xargc_, NULL_TREE, FALSE);
12228
12229 #if 0   /* This is being fixed, and seems to be working now. */
12230   if ((FLOAT_TYPE_SIZE != 32)
12231       || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))) != 32))
12232     {
12233       warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,",
12234                (int) FLOAT_TYPE_SIZE);
12235       warning ("and pointers are %d bits wide, but g77 doesn't yet work",
12236           (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))));
12237       warning ("properly unless they all are 32 bits wide.");
12238       warning ("Please keep this in mind before you report bugs.  g77 should");
12239       warning ("support non-32-bit machines better as of version 0.6.");
12240     }
12241 #endif
12242
12243 #if 0   /* Code in ste.c that would crash has been commented out. */
12244   if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
12245       < TYPE_PRECISION (string_type_node))
12246     /* I/O will probably crash.  */
12247     warning ("configuration: char * holds %d bits, but ftnlen only %d",
12248              TYPE_PRECISION (string_type_node),
12249              TYPE_PRECISION (ffecom_f2c_ftnlen_type_node));
12250 #endif
12251
12252 #if 0   /* ASSIGN-related stuff has been changed to accommodate this. */
12253   if (TYPE_PRECISION (ffecom_integer_type_node)
12254       < TYPE_PRECISION (string_type_node))
12255     /* ASSIGN 10 TO I will crash.  */
12256     warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
12257  ASSIGN statement might fail",
12258              TYPE_PRECISION (string_type_node),
12259              TYPE_PRECISION (ffecom_integer_type_node));
12260 #endif
12261 }
12262
12263 #endif
12264 /* ffecom_init_2 -- Initialize
12265
12266    ffecom_init_2();  */
12267
12268 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12269 void
12270 ffecom_init_2 ()
12271 {
12272   assert (ffecom_outer_function_decl_ == NULL_TREE);
12273   assert (current_function_decl == NULL_TREE);
12274   assert (ffecom_which_entrypoint_decl_ == NULL_TREE);
12275
12276   ffecom_master_arglist_ = NULL;
12277   ++ffecom_num_fns_;
12278   ffecom_primary_entry_ = NULL;
12279   ffecom_is_altreturning_ = FALSE;
12280   ffecom_func_result_ = NULL_TREE;
12281   ffecom_multi_retval_ = NULL_TREE;
12282 }
12283
12284 #endif
12285 /* ffecom_list_expr -- Transform list of exprs into gcc tree
12286
12287    tree t;
12288    ffebld expr;  // FFE opITEM list.
12289    tree = ffecom_list_expr(expr);
12290
12291    List of actual args is transformed into corresponding gcc backend list.  */
12292
12293 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12294 tree
12295 ffecom_list_expr (ffebld expr)
12296 {
12297   tree list;
12298   tree *plist = &list;
12299   tree trail = NULL_TREE;       /* Append char length args here. */
12300   tree *ptrail = &trail;
12301   tree length;
12302
12303   while (expr != NULL)
12304     {
12305       tree texpr = ffecom_arg_expr (ffebld_head (expr), &length);
12306
12307       if (texpr == error_mark_node)
12308         return error_mark_node;
12309
12310       *plist = build_tree_list (NULL_TREE, texpr);
12311       plist = &TREE_CHAIN (*plist);
12312       expr = ffebld_trail (expr);
12313       if (length != NULL_TREE)
12314         {
12315           *ptrail = build_tree_list (NULL_TREE, length);
12316           ptrail = &TREE_CHAIN (*ptrail);
12317         }
12318     }
12319
12320   *plist = trail;
12321
12322   return list;
12323 }
12324
12325 #endif
12326 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
12327
12328    tree t;
12329    ffebld expr;  // FFE opITEM list.
12330    tree = ffecom_list_ptr_to_expr(expr);
12331
12332    List of actual args is transformed into corresponding gcc backend list for
12333    use in calling an external procedure (vs. a statement function).  */
12334
12335 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12336 tree
12337 ffecom_list_ptr_to_expr (ffebld expr)
12338 {
12339   tree list;
12340   tree *plist = &list;
12341   tree trail = NULL_TREE;       /* Append char length args here. */
12342   tree *ptrail = &trail;
12343   tree length;
12344
12345   while (expr != NULL)
12346     {
12347       tree texpr = ffecom_arg_ptr_to_expr (ffebld_head (expr), &length);
12348
12349       if (texpr == error_mark_node)
12350         return error_mark_node;
12351
12352       *plist = build_tree_list (NULL_TREE, texpr);
12353       plist = &TREE_CHAIN (*plist);
12354       expr = ffebld_trail (expr);
12355       if (length != NULL_TREE)
12356         {
12357           *ptrail = build_tree_list (NULL_TREE, length);
12358           ptrail = &TREE_CHAIN (*ptrail);
12359         }
12360     }
12361
12362   *plist = trail;
12363
12364   return list;
12365 }
12366
12367 #endif
12368 /* Obtain gcc's LABEL_DECL tree for label.  */
12369
12370 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12371 tree
12372 ffecom_lookup_label (ffelab label)
12373 {
12374   tree glabel;
12375
12376   if (ffelab_hook (label) == NULL_TREE)
12377     {
12378       char labelname[16];
12379
12380       switch (ffelab_type (label))
12381         {
12382         case FFELAB_typeLOOPEND:
12383         case FFELAB_typeNOTLOOP:
12384         case FFELAB_typeENDIF:
12385           sprintf (labelname, "%" ffelabValue_f "u", ffelab_value (label));
12386           glabel = build_decl (LABEL_DECL, get_identifier (labelname),
12387                                void_type_node);
12388           DECL_CONTEXT (glabel) = current_function_decl;
12389           DECL_MODE (glabel) = VOIDmode;
12390           break;
12391
12392         case FFELAB_typeFORMAT:
12393           glabel = build_decl (VAR_DECL,
12394                                ffecom_get_invented_identifier
12395                                ("__g77_format_%d", (int) ffelab_value (label)),
12396                                build_type_variant (build_array_type
12397                                                    (char_type_node,
12398                                                     NULL_TREE),
12399                                                    1, 0));
12400           TREE_CONSTANT (glabel) = 1;
12401           TREE_STATIC (glabel) = 1;
12402           DECL_CONTEXT (glabel) = 0;
12403           DECL_INITIAL (glabel) = NULL;
12404           make_decl_rtl (glabel, NULL, 0);
12405           expand_decl (glabel);
12406
12407           ffecom_save_tree_forever (glabel);
12408
12409           break;
12410
12411         case FFELAB_typeANY:
12412           glabel = error_mark_node;
12413           break;
12414
12415         default:
12416           assert ("bad label type" == NULL);
12417           glabel = NULL;
12418           break;
12419         }
12420       ffelab_set_hook (label, glabel);
12421     }
12422   else
12423     {
12424       glabel = ffelab_hook (label);
12425     }
12426
12427   return glabel;
12428 }
12429
12430 #endif
12431 /* Stabilizes the arguments.  Don't use this if the lhs and rhs come from
12432    a single source specification (as in the fourth argument of MVBITS).
12433    If the type is NULL_TREE, the type of lhs is used to make the type of
12434    the MODIFY_EXPR.  */
12435
12436 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12437 tree
12438 ffecom_modify (tree newtype, tree lhs,
12439                tree rhs)
12440 {
12441   if (lhs == error_mark_node || rhs == error_mark_node)
12442     return error_mark_node;
12443
12444   if (newtype == NULL_TREE)
12445     newtype = TREE_TYPE (lhs);
12446
12447   if (TREE_SIDE_EFFECTS (lhs))
12448     lhs = stabilize_reference (lhs);
12449
12450   return ffecom_2s (MODIFY_EXPR, newtype, lhs, rhs);
12451 }
12452
12453 #endif
12454
12455 /* Register source file name.  */
12456
12457 void
12458 ffecom_file (const char *name)
12459 {
12460 #if FFECOM_GCC_INCLUDE
12461   ffecom_file_ (name);
12462 #endif
12463 }
12464
12465 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
12466
12467    ffestorag st;
12468    ffecom_notify_init_storage(st);
12469
12470    Gets called when all possible units in an aggregate storage area (a LOCAL
12471    with equivalences or a COMMON) have been initialized.  The initialization
12472    info either is in ffestorag_init or, if that is NULL,
12473    ffestorag_accretion:
12474
12475    ffestorag_init may contain an opCONTER or opARRTER.  opCONTER may occur
12476    even for an array if the array is one element in length!
12477
12478    ffestorag_accretion will contain an opACCTER.  It is much like an
12479    opARRTER except it has an ffebit object in it instead of just a size.
12480    The back end can use the info in the ffebit object, if it wants, to
12481    reduce the amount of actual initialization, but in any case it should
12482    kill the ffebit object when done.  Also, set accretion to NULL but
12483    init to a non-NULL value.
12484
12485    After performing initialization, DO NOT set init to NULL, because that'll
12486    tell the front end it is ok for more initialization to happen.  Instead,
12487    set init to an opANY expression or some such thing that you can use to
12488    tell that you've already initialized the object.
12489
12490    27-Oct-91  JCB  1.1
12491       Support two-pass FFE.  */
12492
12493 void
12494 ffecom_notify_init_storage (ffestorag st)
12495 {
12496   ffebld init;                  /* The initialization expression. */
12497 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12498   ffetargetOffset size;         /* The size of the entity. */
12499   ffetargetAlign pad;           /* Its initial padding. */
12500 #endif
12501
12502   if (ffestorag_init (st) == NULL)
12503     {
12504       init = ffestorag_accretion (st);
12505       assert (init != NULL);
12506       ffestorag_set_accretion (st, NULL);
12507       ffestorag_set_accretes (st, 0);
12508
12509 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12510       /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12511       size = ffebld_accter_size (init);
12512       pad = ffebld_accter_pad (init);
12513       ffebit_kill (ffebld_accter_bits (init));
12514       ffebld_set_op (init, FFEBLD_opARRTER);
12515       ffebld_set_arrter (init, ffebld_accter (init));
12516       ffebld_arrter_set_size (init, size);
12517       ffebld_arrter_set_pad (init, size);
12518 #endif
12519
12520 #if FFECOM_TWOPASS
12521       ffestorag_set_init (st, init);
12522 #endif
12523     }
12524 #if FFECOM_ONEPASS
12525   else
12526     init = ffestorag_init (st);
12527 #endif
12528
12529 #if FFECOM_ONEPASS              /* Process the inits, wipe 'em out. */
12530   ffestorag_set_init (st, ffebld_new_any ());
12531
12532   if (ffebld_op (init) == FFEBLD_opANY)
12533     return;                     /* Oh, we already did this! */
12534
12535 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12536   {
12537     ffesymbol s;
12538
12539     if (ffestorag_symbol (st) != NULL)
12540       s = ffestorag_symbol (st);
12541     else
12542       s = ffestorag_typesymbol (st);
12543
12544     fprintf (dmpout, "= initialize_storage \"%s\" ",
12545              (s != NULL) ? ffesymbol_text (s) : "(unnamed)");
12546     ffebld_dump (init);
12547     fputc ('\n', dmpout);
12548   }
12549 #endif
12550
12551 #endif /* if FFECOM_ONEPASS */
12552 }
12553
12554 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12555
12556    ffesymbol s;
12557    ffecom_notify_init_symbol(s);
12558
12559    Gets called when all possible units in a symbol (not placed in COMMON
12560    or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12561    have been initialized.  The initialization info either is in
12562    ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12563
12564    ffesymbol_init may contain an opCONTER or opARRTER.  opCONTER may occur
12565    even for an array if the array is one element in length!
12566
12567    ffesymbol_accretion will contain an opACCTER.  It is much like an
12568    opARRTER except it has an ffebit object in it instead of just a size.
12569    The back end can use the info in the ffebit object, if it wants, to
12570    reduce the amount of actual initialization, but in any case it should
12571    kill the ffebit object when done.  Also, set accretion to NULL but
12572    init to a non-NULL value.
12573
12574    After performing initialization, DO NOT set init to NULL, because that'll
12575    tell the front end it is ok for more initialization to happen.  Instead,
12576    set init to an opANY expression or some such thing that you can use to
12577    tell that you've already initialized the object.
12578
12579    27-Oct-91  JCB  1.1
12580       Support two-pass FFE.  */
12581
12582 void
12583 ffecom_notify_init_symbol (ffesymbol s)
12584 {
12585   ffebld init;                  /* The initialization expression. */
12586 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12587   ffetargetOffset size;         /* The size of the entity. */
12588   ffetargetAlign pad;           /* Its initial padding. */
12589 #endif
12590
12591   if (ffesymbol_storage (s) == NULL)
12592     return;                     /* Do nothing until COMMON/EQUIVALENCE
12593                                    possibilities checked. */
12594
12595   if ((ffesymbol_init (s) == NULL)
12596       && ((init = ffesymbol_accretion (s)) != NULL))
12597     {
12598       ffesymbol_set_accretion (s, NULL);
12599       ffesymbol_set_accretes (s, 0);
12600
12601 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12602       /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12603       size = ffebld_accter_size (init);
12604       pad = ffebld_accter_pad (init);
12605       ffebit_kill (ffebld_accter_bits (init));
12606       ffebld_set_op (init, FFEBLD_opARRTER);
12607       ffebld_set_arrter (init, ffebld_accter (init));
12608       ffebld_arrter_set_size (init, size);
12609       ffebld_arrter_set_pad (init, size);
12610 #endif
12611
12612 #if FFECOM_TWOPASS
12613       ffesymbol_set_init (s, init);
12614 #endif
12615     }
12616 #if FFECOM_ONEPASS
12617   else
12618     init = ffesymbol_init (s);
12619 #endif
12620
12621 #if FFECOM_ONEPASS
12622   ffesymbol_set_init (s, ffebld_new_any ());
12623
12624   if (ffebld_op (init) == FFEBLD_opANY)
12625     return;                     /* Oh, we already did this! */
12626
12627 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12628   fprintf (dmpout, "= initialize_symbol \"%s\" ", ffesymbol_text (s));
12629   ffebld_dump (init);
12630   fputc ('\n', dmpout);
12631 #endif
12632
12633 #endif /* if FFECOM_ONEPASS */
12634 }
12635
12636 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12637
12638    ffesymbol s;
12639    ffecom_notify_primary_entry(s);
12640
12641    Gets called when implicit or explicit PROGRAM statement seen or when
12642    FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12643    global symbol that serves as the entry point.  */
12644
12645 void
12646 ffecom_notify_primary_entry (ffesymbol s)
12647 {
12648   ffecom_primary_entry_ = s;
12649   ffecom_primary_entry_kind_ = ffesymbol_kind (s);
12650
12651   if ((ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
12652       || (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE))
12653     ffecom_primary_entry_is_proc_ = TRUE;
12654   else
12655     ffecom_primary_entry_is_proc_ = FALSE;
12656
12657   if (!ffe_is_silent ())
12658     {
12659       if (ffecom_primary_entry_kind_ == FFEINFO_kindPROGRAM)
12660         fprintf (stderr, "%s:\n", ffesymbol_text (s));
12661       else
12662         fprintf (stderr, "  %s:\n", ffesymbol_text (s));
12663     }
12664
12665 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12666   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
12667     {
12668       ffebld list;
12669       ffebld arg;
12670
12671       for (list = ffesymbol_dummyargs (s);
12672            list != NULL;
12673            list = ffebld_trail (list))
12674         {
12675           arg = ffebld_head (list);
12676           if (ffebld_op (arg) == FFEBLD_opSTAR)
12677             {
12678               ffecom_is_altreturning_ = TRUE;
12679               break;
12680             }
12681         }
12682     }
12683 #endif
12684 }
12685
12686 FILE *
12687 ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c)
12688 {
12689 #if FFECOM_GCC_INCLUDE
12690   return ffecom_open_include_ (name, l, c);
12691 #else
12692   return fopen (name, "r");
12693 #endif
12694 }
12695
12696 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
12697
12698    tree t;
12699    ffebld expr;  // FFE expression.
12700    tree = ffecom_ptr_to_expr(expr);
12701
12702    Like ffecom_expr, but sticks address-of in front of most things.  */
12703
12704 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12705 tree
12706 ffecom_ptr_to_expr (ffebld expr)
12707 {
12708   tree item;
12709   ffeinfoBasictype bt;
12710   ffeinfoKindtype kt;
12711   ffesymbol s;
12712
12713   assert (expr != NULL);
12714
12715   switch (ffebld_op (expr))
12716     {
12717     case FFEBLD_opSYMTER:
12718       s = ffebld_symter (expr);
12719       if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
12720         {
12721           ffecomGfrt ix;
12722
12723           ix = ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr));
12724           assert (ix != FFECOM_gfrt);
12725           if ((item = ffecom_gfrt_[ix]) == NULL_TREE)
12726             {
12727               ffecom_make_gfrt_ (ix);
12728               item = ffecom_gfrt_[ix];
12729             }
12730         }
12731       else
12732         {
12733           item = ffesymbol_hook (s).decl_tree;
12734           if (item == NULL_TREE)
12735             {
12736               s = ffecom_sym_transform_ (s);
12737               item = ffesymbol_hook (s).decl_tree;
12738             }
12739         }
12740       assert (item != NULL);
12741       if (item == error_mark_node)
12742         return item;
12743       if (!ffesymbol_hook (s).addr)
12744         item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12745                          item);
12746       return item;
12747
12748     case FFEBLD_opARRAYREF:
12749       return ffecom_arrayref_ (NULL_TREE, expr, 1);
12750
12751     case FFEBLD_opCONTER:
12752
12753       bt = ffeinfo_basictype (ffebld_info (expr));
12754       kt = ffeinfo_kindtype (ffebld_info (expr));
12755
12756       item = ffecom_constantunion (&ffebld_constant_union
12757                                    (ffebld_conter (expr)), bt, kt,
12758                                    ffecom_tree_type[bt][kt]);
12759       if (item == error_mark_node)
12760         return error_mark_node;
12761       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12762                        item);
12763       return item;
12764
12765     case FFEBLD_opANY:
12766       return error_mark_node;
12767
12768     default:
12769       bt = ffeinfo_basictype (ffebld_info (expr));
12770       kt = ffeinfo_kindtype (ffebld_info (expr));
12771
12772       item = ffecom_expr (expr);
12773       if (item == error_mark_node)
12774         return error_mark_node;
12775
12776       /* The back end currently optimizes a bit too zealously for us, in that
12777          we fail JCB001 if the following block of code is omitted.  It checks
12778          to see if the transformed expression is a symbol or array reference,
12779          and encloses it in a SAVE_EXPR if that is the case.  */
12780
12781       STRIP_NOPS (item);
12782       if ((TREE_CODE (item) == VAR_DECL)
12783           || (TREE_CODE (item) == PARM_DECL)
12784           || (TREE_CODE (item) == RESULT_DECL)
12785           || (TREE_CODE (item) == INDIRECT_REF)
12786           || (TREE_CODE (item) == ARRAY_REF)
12787           || (TREE_CODE (item) == COMPONENT_REF)
12788 #ifdef OFFSET_REF
12789           || (TREE_CODE (item) == OFFSET_REF)
12790 #endif
12791           || (TREE_CODE (item) == BUFFER_REF)
12792           || (TREE_CODE (item) == REALPART_EXPR)
12793           || (TREE_CODE (item) == IMAGPART_EXPR))
12794         {
12795           item = ffecom_save_tree (item);
12796         }
12797
12798       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12799                        item);
12800       return item;
12801     }
12802
12803   assert ("fall-through error" == NULL);
12804   return error_mark_node;
12805 }
12806
12807 #endif
12808 /* Obtain a temp var with given data type.
12809
12810    size is FFETARGET_charactersizeNONE for a non-CHARACTER type
12811    or >= 0 for a CHARACTER type.
12812
12813    elements is -1 for a scalar or > 0 for an array of type.  */
12814
12815 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12816 tree
12817 ffecom_make_tempvar (const char *commentary, tree type,
12818                      ffetargetCharacterSize size, int elements)
12819 {
12820   int yes;
12821   tree t;
12822   static int mynumber;
12823
12824   assert (current_binding_level->prep_state < 2);
12825
12826   if (type == error_mark_node)
12827     return error_mark_node;
12828
12829   yes = suspend_momentary ();
12830
12831   if (size != FFETARGET_charactersizeNONE)
12832     type = build_array_type (type,
12833                              build_range_type (ffecom_f2c_ftnlen_type_node,
12834                                                ffecom_f2c_ftnlen_one_node,
12835                                                build_int_2 (size, 0)));
12836   if (elements != -1)
12837     type = build_array_type (type,
12838                              build_range_type (integer_type_node,
12839                                                integer_zero_node,
12840                                                build_int_2 (elements - 1,
12841                                                             0)));
12842   t = build_decl (VAR_DECL,
12843                   ffecom_get_invented_identifier ("__g77_%s_%d",
12844                                                   commentary,
12845                                                   mynumber++),
12846                   type);
12847
12848   t = start_decl (t, FALSE);
12849   finish_decl (t, NULL_TREE, FALSE);
12850
12851   resume_momentary (yes);
12852
12853   return t;
12854 }
12855 #endif
12856
12857 /* Prepare argument pointer to expression.
12858
12859    Like ffecom_prepare_expr, except for expressions to be evaluated
12860    via ffecom_arg_ptr_to_expr.  */
12861
12862 void
12863 ffecom_prepare_arg_ptr_to_expr (ffebld expr)
12864 {
12865   /* ~~For now, it seems to be the same thing.  */
12866   ffecom_prepare_expr (expr);
12867   return;
12868 }
12869
12870 /* End of preparations.  */
12871
12872 bool
12873 ffecom_prepare_end (void)
12874 {
12875   int prep_state = current_binding_level->prep_state;
12876
12877   assert (prep_state < 2);
12878   current_binding_level->prep_state = 2;
12879
12880   return (prep_state == 1) ? TRUE : FALSE;
12881 }
12882
12883 /* Prepare expression.
12884
12885    This is called before any code is generated for the current block.
12886    It scans the expression, declares any temporaries that might be needed
12887    during evaluation of the expression, and stores those temporaries in
12888    the appropriate "hook" fields of the expression.  `dest', if not NULL,
12889    specifies the destination that ffecom_expr_ will see, in case that
12890    helps avoid generating unused temporaries.
12891
12892    ~~Improve to avoid allocating unused temporaries by taking `dest'
12893    into account vis-a-vis aliasing requirements of complex/character
12894    functions.  */
12895
12896 void
12897 ffecom_prepare_expr_ (ffebld expr, ffebld dest UNUSED)
12898 {
12899   ffeinfoBasictype bt;
12900   ffeinfoKindtype kt;
12901   ffetargetCharacterSize sz;
12902   tree tempvar = NULL_TREE;
12903
12904   assert (current_binding_level->prep_state < 2);
12905
12906   if (! expr)
12907     return;
12908
12909   bt = ffeinfo_basictype (ffebld_info (expr));
12910   kt = ffeinfo_kindtype (ffebld_info (expr));
12911   sz = ffeinfo_size (ffebld_info (expr));
12912
12913   /* Generate whatever temporaries are needed to represent the result
12914      of the expression.  */
12915
12916   if (bt == FFEINFO_basictypeCHARACTER)
12917     {
12918       while (ffebld_op (expr) == FFEBLD_opPAREN)
12919         expr = ffebld_left (expr);
12920     }
12921
12922   switch (ffebld_op (expr))
12923     {
12924     default:
12925       /* Don't make temps for SYMTER, CONTER, etc.  */
12926       if (ffebld_arity (expr) == 0)
12927         break;
12928
12929       switch (bt)
12930         {
12931         case FFEINFO_basictypeCOMPLEX:
12932           if (ffebld_op (expr) == FFEBLD_opFUNCREF)
12933             {
12934               ffesymbol s;
12935
12936               if (ffebld_op (ffebld_left (expr)) != FFEBLD_opSYMTER)
12937                 break;
12938
12939               s = ffebld_symter (ffebld_left (expr));
12940               if (ffesymbol_where (s) == FFEINFO_whereCONSTANT
12941                   || (ffesymbol_where (s) != FFEINFO_whereINTRINSIC
12942                       && ! ffesymbol_is_f2c (s))
12943                   || (ffesymbol_where (s) == FFEINFO_whereINTRINSIC
12944                       && ! ffe_is_f2c_library ()))
12945                 break;
12946             }
12947           else if (ffebld_op (expr) == FFEBLD_opPOWER)
12948             {
12949               /* Requires special treatment.  There's no POW_CC function
12950                  in libg2c, so POW_ZZ is used, which means we always
12951                  need a double-complex temp, not a single-complex.  */
12952               kt = FFEINFO_kindtypeREAL2;
12953             }
12954           else if (ffebld_op (expr) != FFEBLD_opDIVIDE)
12955             /* The other ops don't need temps for complex operands.  */
12956             break;
12957
12958           /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
12959              REAL(C).  See 19990325-0.f, routine `check', for cases.  */
12960           tempvar = ffecom_make_tempvar ("complex",
12961                                          ffecom_tree_type
12962                                          [FFEINFO_basictypeCOMPLEX][kt],
12963                                          FFETARGET_charactersizeNONE,
12964                                          -1);
12965           break;
12966
12967         case FFEINFO_basictypeCHARACTER:
12968           if (ffebld_op (expr) != FFEBLD_opFUNCREF)
12969             break;
12970
12971           if (sz == FFETARGET_charactersizeNONE)
12972             /* ~~Kludge alert!  This should someday be fixed. */
12973             sz = 24;
12974
12975           tempvar = ffecom_make_tempvar ("char", char_type_node, sz, -1);
12976           break;
12977
12978         default:
12979           break;
12980         }
12981       break;
12982
12983 #ifdef HAHA
12984     case FFEBLD_opPOWER:
12985       {
12986         tree rtype, ltype;
12987         tree rtmp, ltmp, result;
12988
12989         ltype = ffecom_type_expr (ffebld_left (expr));
12990         rtype = ffecom_type_expr (ffebld_right (expr));
12991
12992         rtmp = ffecom_make_tempvar (rtype, FFETARGET_charactersizeNONE, -1);
12993         ltmp = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12994         result = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12995
12996         tempvar = make_tree_vec (3);
12997         TREE_VEC_ELT (tempvar, 0) = rtmp;
12998         TREE_VEC_ELT (tempvar, 1) = ltmp;
12999         TREE_VEC_ELT (tempvar, 2) = result;
13000       }
13001       break;
13002 #endif  /* HAHA */
13003
13004     case FFEBLD_opCONCATENATE:
13005       {
13006         /* This gets special handling, because only one set of temps
13007            is needed for a tree of these -- the tree is treated as
13008            a flattened list of concatenations when generating code.  */
13009
13010         ffecomConcatList_ catlist;
13011         tree ltmp, itmp, result;
13012         int count;
13013         int i;
13014
13015         catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
13016         count = ffecom_concat_list_count_ (catlist);
13017
13018         if (count >= 2)
13019           {
13020             ltmp
13021               = ffecom_make_tempvar ("concat_len",
13022                                      ffecom_f2c_ftnlen_type_node,
13023                                      FFETARGET_charactersizeNONE, count);
13024             itmp
13025               = ffecom_make_tempvar ("concat_item",
13026                                      ffecom_f2c_address_type_node,
13027                                      FFETARGET_charactersizeNONE, count);
13028             result
13029               = ffecom_make_tempvar ("concat_res",
13030                                      char_type_node,
13031                                      ffecom_concat_list_maxlen_ (catlist),
13032                                      -1);
13033
13034             tempvar = make_tree_vec (3);
13035             TREE_VEC_ELT (tempvar, 0) = ltmp;
13036             TREE_VEC_ELT (tempvar, 1) = itmp;
13037             TREE_VEC_ELT (tempvar, 2) = result;
13038           }
13039
13040         for (i = 0; i < count; ++i)
13041           ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist,
13042                                                                     i));
13043
13044         ffecom_concat_list_kill_ (catlist);
13045
13046         if (tempvar)
13047           {
13048             ffebld_nonter_set_hook (expr, tempvar);
13049             current_binding_level->prep_state = 1;
13050           }
13051       }
13052       return;
13053
13054     case FFEBLD_opCONVERT:
13055       if (bt == FFEINFO_basictypeCHARACTER
13056           && ((ffebld_size_known (ffebld_left (expr))
13057                == FFETARGET_charactersizeNONE)
13058               || (ffebld_size_known (ffebld_left (expr)) >= sz)))
13059         tempvar = ffecom_make_tempvar ("convert", char_type_node, sz, -1);
13060       break;
13061     }
13062
13063   if (tempvar)
13064     {
13065       ffebld_nonter_set_hook (expr, tempvar);
13066       current_binding_level->prep_state = 1;
13067     }
13068
13069   /* Prepare subexpressions for this expr.  */
13070
13071   switch (ffebld_op (expr))
13072     {
13073     case FFEBLD_opPERCENT_LOC:
13074       ffecom_prepare_ptr_to_expr (ffebld_left (expr));
13075       break;
13076
13077     case FFEBLD_opPERCENT_VAL:
13078     case FFEBLD_opPERCENT_REF:
13079       ffecom_prepare_expr (ffebld_left (expr));
13080       break;
13081
13082     case FFEBLD_opPERCENT_DESCR:
13083       ffecom_prepare_arg_ptr_to_expr (ffebld_left (expr));
13084       break;
13085
13086     case FFEBLD_opITEM:
13087       {
13088         ffebld item;
13089
13090         for (item = expr;
13091              item != NULL;
13092              item = ffebld_trail (item))
13093           if (ffebld_head (item) != NULL)
13094             ffecom_prepare_expr (ffebld_head (item));
13095       }
13096       break;
13097
13098     default:
13099       /* Need to handle character conversion specially.  */
13100       switch (ffebld_arity (expr))
13101         {
13102         case 2:
13103           ffecom_prepare_expr (ffebld_left (expr));
13104           ffecom_prepare_expr (ffebld_right (expr));
13105           break;
13106
13107         case 1:
13108           ffecom_prepare_expr (ffebld_left (expr));
13109           break;
13110
13111         default:
13112           break;
13113         }
13114     }
13115
13116   return;
13117 }
13118
13119 /* Prepare expression for reading and writing.
13120
13121    Like ffecom_prepare_expr, except for expressions to be evaluated
13122    via ffecom_expr_rw.  */
13123
13124 void
13125 ffecom_prepare_expr_rw (tree type, ffebld expr)
13126 {
13127   /* This is all we support for now.  */
13128   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
13129
13130   /* ~~For now, it seems to be the same thing.  */
13131   ffecom_prepare_expr (expr);
13132   return;
13133 }
13134
13135 /* Prepare expression for writing.
13136
13137    Like ffecom_prepare_expr, except for expressions to be evaluated
13138    via ffecom_expr_w.  */
13139
13140 void
13141 ffecom_prepare_expr_w (tree type, ffebld expr)
13142 {
13143   /* This is all we support for now.  */
13144   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
13145
13146   /* ~~For now, it seems to be the same thing.  */
13147   ffecom_prepare_expr (expr);
13148   return;
13149 }
13150
13151 /* Prepare expression for returning.
13152
13153    Like ffecom_prepare_expr, except for expressions to be evaluated
13154    via ffecom_return_expr.  */
13155
13156 void
13157 ffecom_prepare_return_expr (ffebld expr)
13158 {
13159   assert (current_binding_level->prep_state < 2);
13160
13161   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE
13162       && ffecom_is_altreturning_
13163       && expr != NULL)
13164     ffecom_prepare_expr (expr);
13165 }
13166
13167 /* Prepare pointer to expression.
13168
13169    Like ffecom_prepare_expr, except for expressions to be evaluated
13170    via ffecom_ptr_to_expr.  */
13171
13172 void
13173 ffecom_prepare_ptr_to_expr (ffebld expr)
13174 {
13175   /* ~~For now, it seems to be the same thing.  */
13176   ffecom_prepare_expr (expr);
13177   return;
13178 }
13179
13180 /* Transform expression into constant pointer-to-expression tree.
13181
13182    If the expression can be transformed into a pointer-to-expression tree
13183    that is constant, that is done, and the tree returned.  Else NULL_TREE
13184    is returned.
13185
13186    That way, a caller can attempt to provide compile-time initialization
13187    of a variable and, if that fails, *then* choose to start a new block
13188    and resort to using temporaries, as appropriate.  */
13189
13190 tree
13191 ffecom_ptr_to_const_expr (ffebld expr)
13192 {
13193   if (! expr)
13194     return integer_zero_node;
13195
13196   if (ffebld_op (expr) == FFEBLD_opANY)
13197     return error_mark_node;
13198
13199   if (ffebld_arity (expr) == 0
13200       && (ffebld_op (expr) != FFEBLD_opSYMTER
13201           || ffebld_where (expr) == FFEINFO_whereCOMMON
13202           || ffebld_where (expr) == FFEINFO_whereGLOBAL
13203           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
13204     {
13205       tree t;
13206
13207       t = ffecom_ptr_to_expr (expr);
13208       assert (TREE_CONSTANT (t));
13209       return t;
13210     }
13211
13212   return NULL_TREE;
13213 }
13214
13215 /* ffecom_return_expr -- Returns return-value expr given alt return expr
13216
13217    tree rtn;  // NULL_TREE means use expand_null_return()
13218    ffebld expr;  // NULL if no alt return expr to RETURN stmt
13219    rtn = ffecom_return_expr(expr);
13220
13221    Based on the program unit type and other info (like return function
13222    type, return master function type when alternate ENTRY points,
13223    whether subroutine has any alternate RETURN points, etc), returns the
13224    appropriate expression to be returned to the caller, or NULL_TREE
13225    meaning no return value or the caller expects it to be returned somewhere
13226    else (which is handled by other parts of this module).  */
13227
13228 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13229 tree
13230 ffecom_return_expr (ffebld expr)
13231 {
13232   tree rtn;
13233
13234   switch (ffecom_primary_entry_kind_)
13235     {
13236     case FFEINFO_kindPROGRAM:
13237     case FFEINFO_kindBLOCKDATA:
13238       rtn = NULL_TREE;
13239       break;
13240
13241     case FFEINFO_kindSUBROUTINE:
13242       if (!ffecom_is_altreturning_)
13243         rtn = NULL_TREE;        /* No alt returns, never an expr. */
13244       else if (expr == NULL)
13245         rtn = integer_zero_node;
13246       else
13247         rtn = ffecom_expr (expr);
13248       break;
13249
13250     case FFEINFO_kindFUNCTION:
13251       if ((ffecom_multi_retval_ != NULL_TREE)
13252           || (ffesymbol_basictype (ffecom_primary_entry_)
13253               == FFEINFO_basictypeCHARACTER)
13254           || ((ffesymbol_basictype (ffecom_primary_entry_)
13255                == FFEINFO_basictypeCOMPLEX)
13256               && (ffecom_num_entrypoints_ == 0)
13257               && ffesymbol_is_f2c (ffecom_primary_entry_)))
13258         {                       /* Value is returned by direct assignment
13259                                    into (implicit) dummy. */
13260           rtn = NULL_TREE;
13261           break;
13262         }
13263       rtn = ffecom_func_result_;
13264 #if 0
13265       /* Spurious error if RETURN happens before first reference!  So elide
13266          this code.  In particular, for debugging registry, rtn should always
13267          be non-null after all, but TREE_USED won't be set until we encounter
13268          a reference in the code.  Perfectly okay (but weird) code that,
13269          e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
13270          this diagnostic for no reason.  Have people use -O -Wuninitialized
13271          and leave it to the back end to find obviously weird cases.  */
13272
13273       /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
13274          situation; if the return value has never been referenced, it won't
13275          have a tree under 2pass mode. */
13276       if ((rtn == NULL_TREE)
13277           || !TREE_USED (rtn))
13278         {
13279           ffebad_start (FFEBAD_RETURN_VALUE_UNSET);
13280           ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_),
13281                        ffesymbol_where_column (ffecom_primary_entry_));
13282           ffebad_string (ffesymbol_text (ffesymbol_funcresult
13283                                          (ffecom_primary_entry_)));
13284           ffebad_finish ();
13285         }
13286 #endif
13287       break;
13288
13289     default:
13290       assert ("bad unit kind" == NULL);
13291     case FFEINFO_kindANY:
13292       rtn = error_mark_node;
13293       break;
13294     }
13295
13296   return rtn;
13297 }
13298
13299 #endif
13300 /* Do save_expr only if tree is not error_mark_node.  */
13301
13302 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13303 tree
13304 ffecom_save_tree (tree t)
13305 {
13306   return save_expr (t);
13307 }
13308 #endif
13309
13310 /* Start a compound statement (block).  */
13311
13312 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13313 void
13314 ffecom_start_compstmt (void)
13315 {
13316   bison_rule_pushlevel_ ();
13317 }
13318 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
13319
13320 /* Public entry point for front end to access start_decl.  */
13321
13322 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13323 tree
13324 ffecom_start_decl (tree decl, bool is_initialized)
13325 {
13326   DECL_INITIAL (decl) = is_initialized ? error_mark_node : NULL_TREE;
13327   return start_decl (decl, FALSE);
13328 }
13329
13330 #endif
13331 /* ffecom_sym_commit -- Symbol's state being committed to reality
13332
13333    ffesymbol s;
13334    ffecom_sym_commit(s);
13335
13336    Does whatever the backend needs when a symbol is committed after having
13337    been backtrackable for a period of time.  */
13338
13339 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13340 void
13341 ffecom_sym_commit (ffesymbol s UNUSED)
13342 {
13343   assert (!ffesymbol_retractable ());
13344 }
13345
13346 #endif
13347 /* ffecom_sym_end_transition -- Perform end transition on all symbols
13348
13349    ffecom_sym_end_transition();
13350
13351    Does backend-specific stuff and also calls ffest_sym_end_transition
13352    to do the necessary FFE stuff.
13353
13354    Backtracking is never enabled when this fn is called, so don't worry
13355    about it.  */
13356
13357 ffesymbol
13358 ffecom_sym_end_transition (ffesymbol s)
13359 {
13360   ffestorag st;
13361
13362   assert (!ffesymbol_retractable ());
13363
13364   s = ffest_sym_end_transition (s);
13365
13366 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13367   if ((ffesymbol_kind (s) == FFEINFO_kindBLOCKDATA)
13368       && (ffesymbol_where (s) == FFEINFO_whereGLOBAL))
13369     {
13370       ffecom_list_blockdata_
13371         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
13372                                               FFEINTRIN_specNONE,
13373                                               FFEINTRIN_impNONE),
13374                            ffecom_list_blockdata_);
13375     }
13376 #endif
13377
13378   /* This is where we finally notice that a symbol has partial initialization
13379      and finalize it. */
13380
13381   if (ffesymbol_accretion (s) != NULL)
13382     {
13383       assert (ffesymbol_init (s) == NULL);
13384       ffecom_notify_init_symbol (s);
13385     }
13386   else if (((st = ffesymbol_storage (s)) != NULL)
13387            && ((st = ffestorag_parent (st)) != NULL)
13388            && (ffestorag_accretion (st) != NULL))
13389     {
13390       assert (ffestorag_init (st) == NULL);
13391       ffecom_notify_init_storage (st);
13392     }
13393
13394 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13395   if ((ffesymbol_kind (s) == FFEINFO_kindCOMMON)
13396       && (ffesymbol_where (s) == FFEINFO_whereLOCAL)
13397       && (ffesymbol_storage (s) != NULL))
13398     {
13399       ffecom_list_common_
13400         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
13401                                               FFEINTRIN_specNONE,
13402                                               FFEINTRIN_impNONE),
13403                            ffecom_list_common_);
13404     }
13405 #endif
13406
13407   return s;
13408 }
13409
13410 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
13411
13412    ffecom_sym_exec_transition();
13413
13414    Does backend-specific stuff and also calls ffest_sym_exec_transition
13415    to do the necessary FFE stuff.
13416
13417    See the long-winded description in ffecom_sym_learned for info
13418    on handling the situation where backtracking is inhibited.  */
13419
13420 ffesymbol
13421 ffecom_sym_exec_transition (ffesymbol s)
13422 {
13423   s = ffest_sym_exec_transition (s);
13424
13425   return s;
13426 }
13427
13428 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
13429
13430    ffesymbol s;
13431    s = ffecom_sym_learned(s);
13432
13433    Called when a new symbol is seen after the exec transition or when more
13434    info (perhaps) is gained for an UNCERTAIN symbol.  The symbol state when
13435    it arrives here is that all its latest info is updated already, so its
13436    state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
13437    field filled in if its gone through here or exec_transition first, and
13438    so on.
13439
13440    The backend probably wants to check ffesymbol_retractable() to see if
13441    backtracking is in effect.  If so, the FFE's changes to the symbol may
13442    be retracted (undone) or committed (ratified), at which time the
13443    appropriate ffecom_sym_retract or _commit function will be called
13444    for that function.
13445
13446    If the backend has its own backtracking mechanism, great, use it so that
13447    committal is a simple operation.  Though it doesn't make much difference,
13448    I suppose: the reason for tentative symbol evolution in the FFE is to
13449    enable error detection in weird incorrect statements early and to disable
13450    incorrect error detection on a correct statement.  The backend is not
13451    likely to introduce any information that'll get involved in these
13452    considerations, so it is probably just fine that the implementation
13453    model for this fn and for _exec_transition is to not do anything
13454    (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
13455    and instead wait until ffecom_sym_commit is called (which it never
13456    will be as long as we're using ambiguity-detecting statement analysis in
13457    the FFE, which we are initially to shake out the code, but don't depend
13458    on this), otherwise go ahead and do whatever is needed.
13459
13460    In essence, then, when this fn and _exec_transition get called while
13461    backtracking is enabled, a general mechanism would be to flag which (or
13462    both) of these were called (and in what order? neat question as to what
13463    might happen that I'm too lame to think through right now) and then when
13464    _commit is called reproduce the original calling sequence, if any, for
13465    the two fns (at which point backtracking will, of course, be disabled).  */
13466
13467 ffesymbol
13468 ffecom_sym_learned (ffesymbol s)
13469 {
13470   ffestorag_exec_layout (s);
13471
13472   return s;
13473 }
13474
13475 /* ffecom_sym_retract -- Symbol's state being retracted from reality
13476
13477    ffesymbol s;
13478    ffecom_sym_retract(s);
13479
13480    Does whatever the backend needs when a symbol is retracted after having
13481    been backtrackable for a period of time.  */
13482
13483 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13484 void
13485 ffecom_sym_retract (ffesymbol s UNUSED)
13486 {
13487   assert (!ffesymbol_retractable ());
13488
13489 #if 0                           /* GCC doesn't commit any backtrackable sins,
13490                                    so nothing needed here. */
13491   switch (ffesymbol_hook (s).state)
13492     {
13493     case 0:                     /* nothing happened yet. */
13494       break;
13495
13496     case 1:                     /* exec transition happened. */
13497       break;
13498
13499     case 2:                     /* learned happened. */
13500       break;
13501
13502     case 3:                     /* learned then exec. */
13503       break;
13504
13505     case 4:                     /* exec then learned. */
13506       break;
13507
13508     default:
13509       assert ("bad hook state" == NULL);
13510       break;
13511     }
13512 #endif
13513 }
13514
13515 #endif
13516 /* Create temporary gcc label.  */
13517
13518 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13519 tree
13520 ffecom_temp_label ()
13521 {
13522   tree glabel;
13523   static int mynumber = 0;
13524
13525   glabel = build_decl (LABEL_DECL,
13526                        ffecom_get_invented_identifier ("__g77_label_%d",
13527                                                        mynumber++),
13528                        void_type_node);
13529   DECL_CONTEXT (glabel) = current_function_decl;
13530   DECL_MODE (glabel) = VOIDmode;
13531
13532   return glabel;
13533 }
13534
13535 #endif
13536 /* Return an expression that is usable as an arg in a conditional context
13537    (IF, DO WHILE, .NOT., and so on).
13538
13539    Use the one provided for the back end as of >2.6.0.  */
13540
13541 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13542 tree
13543 ffecom_truth_value (tree expr)
13544 {
13545   return truthvalue_conversion (expr);
13546 }
13547
13548 #endif
13549 /* Return the inversion of a truth value (the inversion of what
13550    ffecom_truth_value builds).
13551
13552    Apparently invert_truthvalue, which is properly in the back end, is
13553    enough for now, so just use it.  */
13554
13555 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13556 tree
13557 ffecom_truth_value_invert (tree expr)
13558 {
13559   return invert_truthvalue (ffecom_truth_value (expr));
13560 }
13561
13562 #endif
13563
13564 /* Return the tree that is the type of the expression, as would be
13565    returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
13566    transforming the expression, generating temporaries, etc.  */
13567
13568 tree
13569 ffecom_type_expr (ffebld expr)
13570 {
13571   ffeinfoBasictype bt;
13572   ffeinfoKindtype kt;
13573   tree tree_type;
13574
13575   assert (expr != NULL);
13576
13577   bt = ffeinfo_basictype (ffebld_info (expr));
13578   kt = ffeinfo_kindtype (ffebld_info (expr));
13579   tree_type = ffecom_tree_type[bt][kt];
13580
13581   switch (ffebld_op (expr))
13582     {
13583     case FFEBLD_opCONTER:
13584     case FFEBLD_opSYMTER:
13585     case FFEBLD_opARRAYREF:
13586     case FFEBLD_opUPLUS:
13587     case FFEBLD_opPAREN:
13588     case FFEBLD_opUMINUS:
13589     case FFEBLD_opADD:
13590     case FFEBLD_opSUBTRACT:
13591     case FFEBLD_opMULTIPLY:
13592     case FFEBLD_opDIVIDE:
13593     case FFEBLD_opPOWER:
13594     case FFEBLD_opNOT:
13595     case FFEBLD_opFUNCREF:
13596     case FFEBLD_opSUBRREF:
13597     case FFEBLD_opAND:
13598     case FFEBLD_opOR:
13599     case FFEBLD_opXOR:
13600     case FFEBLD_opNEQV:
13601     case FFEBLD_opEQV:
13602     case FFEBLD_opCONVERT:
13603     case FFEBLD_opLT:
13604     case FFEBLD_opLE:
13605     case FFEBLD_opEQ:
13606     case FFEBLD_opNE:
13607     case FFEBLD_opGT:
13608     case FFEBLD_opGE:
13609     case FFEBLD_opPERCENT_LOC:
13610       return tree_type;
13611
13612     case FFEBLD_opACCTER:
13613     case FFEBLD_opARRTER:
13614     case FFEBLD_opITEM:
13615     case FFEBLD_opSTAR:
13616     case FFEBLD_opBOUNDS:
13617     case FFEBLD_opREPEAT:
13618     case FFEBLD_opLABTER:
13619     case FFEBLD_opLABTOK:
13620     case FFEBLD_opIMPDO:
13621     case FFEBLD_opCONCATENATE:
13622     case FFEBLD_opSUBSTR:
13623     default:
13624       assert ("bad op for ffecom_type_expr" == NULL);
13625       /* Fall through. */
13626     case FFEBLD_opANY:
13627       return error_mark_node;
13628     }
13629 }
13630
13631 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13632
13633    If the PARM_DECL already exists, return it, else create it.  It's an
13634    integer_type_node argument for the master function that implements a
13635    subroutine or function with more than one entrypoint and is bound at
13636    run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13637    first ENTRY statement, and so on).  */
13638
13639 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13640 tree
13641 ffecom_which_entrypoint_decl ()
13642 {
13643   assert (ffecom_which_entrypoint_decl_ != NULL_TREE);
13644
13645   return ffecom_which_entrypoint_decl_;
13646 }
13647
13648 #endif
13649 \f
13650 /* The following sections consists of private and public functions
13651    that have the same names and perform roughly the same functions
13652    as counterparts in the C front end.  Changes in the C front end
13653    might affect how things should be done here.  Only functions
13654    needed by the back end should be public here; the rest should
13655    be private (static in the C sense).  Functions needed by other
13656    g77 front-end modules should be accessed by them via public
13657    ffecom_* names, which should themselves call private versions
13658    in this section so the private versions are easy to recognize
13659    when upgrading to a new gcc and finding interesting changes
13660    in the front end.
13661
13662    Functions named after rule "foo:" in c-parse.y are named
13663    "bison_rule_foo_" so they are easy to find.  */
13664
13665 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13666
13667 static void
13668 bison_rule_pushlevel_ ()
13669 {
13670   emit_line_note (input_filename, lineno);
13671   pushlevel (0);
13672   clear_last_expr ();
13673   push_momentary ();
13674   expand_start_bindings (0);
13675 }
13676
13677 static tree
13678 bison_rule_compstmt_ ()
13679 {
13680   tree t;
13681   int keep = kept_level_p ();
13682
13683   /* Make the temps go away.  */
13684   if (! keep)
13685     current_binding_level->names = NULL_TREE;
13686
13687   emit_line_note (input_filename, lineno);
13688   expand_end_bindings (getdecls (), keep, 0);
13689   t = poplevel (keep, 1, 0);
13690   pop_momentary ();
13691
13692   return t;
13693 }
13694
13695 /* Return a definition for a builtin function named NAME and whose data type
13696    is TYPE.  TYPE should be a function type with argument types.
13697    FUNCTION_CODE tells later passes how to compile calls to this function.
13698    See tree.h for its possible values.
13699
13700    If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13701    the name to be called if we can't opencode the function.  */
13702
13703 tree
13704 builtin_function (const char *name, tree type, int function_code,
13705                   enum built_in_class class,
13706                   const char *library_name)
13707 {
13708   tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
13709   DECL_EXTERNAL (decl) = 1;
13710   TREE_PUBLIC (decl) = 1;
13711   if (library_name)
13712     DECL_ASSEMBLER_NAME (decl) = get_identifier (library_name);
13713   make_decl_rtl (decl, NULL_PTR, 1);
13714   pushdecl (decl);
13715   DECL_BUILT_IN_CLASS (decl) = class;
13716   DECL_FUNCTION_CODE (decl) = function_code;
13717
13718   return decl;
13719 }
13720
13721 /* Handle when a new declaration NEWDECL
13722    has the same name as an old one OLDDECL
13723    in the same binding contour.
13724    Prints an error message if appropriate.
13725
13726    If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13727    Otherwise, return 0.  */
13728
13729 static int
13730 duplicate_decls (tree newdecl, tree olddecl)
13731 {
13732   int types_match = 1;
13733   int new_is_definition = (TREE_CODE (newdecl) == FUNCTION_DECL
13734                            && DECL_INITIAL (newdecl) != 0);
13735   tree oldtype = TREE_TYPE (olddecl);
13736   tree newtype = TREE_TYPE (newdecl);
13737
13738   if (olddecl == newdecl)
13739     return 1;
13740
13741   if (TREE_CODE (newtype) == ERROR_MARK
13742       || TREE_CODE (oldtype) == ERROR_MARK)
13743     types_match = 0;
13744
13745   /* New decl is completely inconsistent with the old one =>
13746      tell caller to replace the old one.
13747      This is always an error except in the case of shadowing a builtin.  */
13748   if (TREE_CODE (olddecl) != TREE_CODE (newdecl))
13749     return 0;
13750
13751   /* For real parm decl following a forward decl,
13752      return 1 so old decl will be reused.  */
13753   if (types_match && TREE_CODE (newdecl) == PARM_DECL
13754       && TREE_ASM_WRITTEN (olddecl) && ! TREE_ASM_WRITTEN (newdecl))
13755     return 1;
13756
13757   /* The new declaration is the same kind of object as the old one.
13758      The declarations may partially match.  Print warnings if they don't
13759      match enough.  Ultimately, copy most of the information from the new
13760      decl to the old one, and keep using the old one.  */
13761
13762   if (TREE_CODE (olddecl) == FUNCTION_DECL
13763       && DECL_BUILT_IN (olddecl))
13764     {
13765       /* A function declaration for a built-in function.  */
13766       if (!TREE_PUBLIC (newdecl))
13767         return 0;
13768       else if (!types_match)
13769         {
13770           /* Accept the return type of the new declaration if same modes.  */
13771           tree oldreturntype = TREE_TYPE (TREE_TYPE (olddecl));
13772           tree newreturntype = TREE_TYPE (TREE_TYPE (newdecl));
13773
13774           if (TYPE_MODE (oldreturntype) == TYPE_MODE (newreturntype))
13775             {
13776               /* Function types may be shared, so we can't just modify
13777                  the return type of olddecl's function type.  */
13778               tree newtype
13779                 = build_function_type (newreturntype,
13780                                        TYPE_ARG_TYPES (TREE_TYPE (olddecl)));
13781
13782               types_match = 1;
13783               if (types_match)
13784                 TREE_TYPE (olddecl) = newtype;
13785             }
13786         }
13787       if (!types_match)
13788         return 0;
13789     }
13790   else if (TREE_CODE (olddecl) == FUNCTION_DECL
13791            && DECL_SOURCE_LINE (olddecl) == 0)
13792     {
13793       /* A function declaration for a predeclared function
13794          that isn't actually built in.  */
13795       if (!TREE_PUBLIC (newdecl))
13796         return 0;
13797       else if (!types_match)
13798         {
13799           /* If the types don't match, preserve volatility indication.
13800              Later on, we will discard everything else about the
13801              default declaration.  */
13802           TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl);
13803         }
13804     }
13805
13806   /* Copy all the DECL_... slots specified in the new decl
13807      except for any that we copy here from the old type.
13808
13809      Past this point, we don't change OLDTYPE and NEWTYPE
13810      even if we change the types of NEWDECL and OLDDECL.  */
13811
13812   if (types_match)
13813     {
13814       /* Merge the data types specified in the two decls.  */
13815       if (TREE_CODE (newdecl) != FUNCTION_DECL || !DECL_BUILT_IN (olddecl))
13816         TREE_TYPE (newdecl)
13817           = TREE_TYPE (olddecl)
13818             = TREE_TYPE (newdecl);
13819
13820       /* Lay the type out, unless already done.  */
13821       if (oldtype != TREE_TYPE (newdecl))
13822         {
13823           if (TREE_TYPE (newdecl) != error_mark_node)
13824             layout_type (TREE_TYPE (newdecl));
13825           if (TREE_CODE (newdecl) != FUNCTION_DECL
13826               && TREE_CODE (newdecl) != TYPE_DECL
13827               && TREE_CODE (newdecl) != CONST_DECL)
13828             layout_decl (newdecl, 0);
13829         }
13830       else
13831         {
13832           /* Since the type is OLDDECL's, make OLDDECL's size go with.  */
13833           DECL_SIZE (newdecl) = DECL_SIZE (olddecl);
13834           DECL_SIZE_UNIT (newdecl) = DECL_SIZE_UNIT (olddecl);
13835           if (TREE_CODE (olddecl) != FUNCTION_DECL)
13836             if (DECL_ALIGN (olddecl) > DECL_ALIGN (newdecl))
13837               {
13838                 DECL_ALIGN (newdecl) = DECL_ALIGN (olddecl);
13839                 DECL_USER_ALIGN (newdecl) |= DECL_USER_ALIGN (olddecl);
13840               }
13841         }
13842
13843       /* Keep the old rtl since we can safely use it.  */
13844       DECL_RTL (newdecl) = DECL_RTL (olddecl);
13845
13846       /* Merge the type qualifiers.  */
13847       if (DECL_BUILT_IN_NONANSI (olddecl) && TREE_THIS_VOLATILE (olddecl)
13848           && !TREE_THIS_VOLATILE (newdecl))
13849         TREE_THIS_VOLATILE (olddecl) = 0;
13850       if (TREE_READONLY (newdecl))
13851         TREE_READONLY (olddecl) = 1;
13852       if (TREE_THIS_VOLATILE (newdecl))
13853         {
13854           TREE_THIS_VOLATILE (olddecl) = 1;
13855           if (TREE_CODE (newdecl) == VAR_DECL)
13856             make_var_volatile (newdecl);
13857         }
13858
13859       /* Keep source location of definition rather than declaration.
13860          Likewise, keep decl at outer scope.  */
13861       if ((DECL_INITIAL (newdecl) == 0 && DECL_INITIAL (olddecl) != 0)
13862           || (DECL_CONTEXT (newdecl) != 0 && DECL_CONTEXT (olddecl) == 0))
13863         {
13864           DECL_SOURCE_LINE (newdecl) = DECL_SOURCE_LINE (olddecl);
13865           DECL_SOURCE_FILE (newdecl) = DECL_SOURCE_FILE (olddecl);
13866
13867           if (DECL_CONTEXT (olddecl) == 0
13868               && TREE_CODE (newdecl) != FUNCTION_DECL)
13869             DECL_CONTEXT (newdecl) = 0;
13870         }
13871
13872       /* Merge the unused-warning information.  */
13873       if (DECL_IN_SYSTEM_HEADER (olddecl))
13874         DECL_IN_SYSTEM_HEADER (newdecl) = 1;
13875       else if (DECL_IN_SYSTEM_HEADER (newdecl))
13876         DECL_IN_SYSTEM_HEADER (olddecl) = 1;
13877
13878       /* Merge the initialization information.  */
13879       if (DECL_INITIAL (newdecl) == 0)
13880         DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13881
13882       /* Merge the section attribute.
13883          We want to issue an error if the sections conflict but that must be
13884          done later in decl_attributes since we are called before attributes
13885          are assigned.  */
13886       if (DECL_SECTION_NAME (newdecl) == NULL_TREE)
13887         DECL_SECTION_NAME (newdecl) = DECL_SECTION_NAME (olddecl);
13888
13889 #if BUILT_FOR_270
13890       if (TREE_CODE (newdecl) == FUNCTION_DECL)
13891         {
13892           DECL_STATIC_CONSTRUCTOR(newdecl) |= DECL_STATIC_CONSTRUCTOR(olddecl);
13893           DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl);
13894         }
13895 #endif
13896     }
13897   /* If cannot merge, then use the new type and qualifiers,
13898      and don't preserve the old rtl.  */
13899   else
13900     {
13901       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13902       TREE_READONLY (olddecl) = TREE_READONLY (newdecl);
13903       TREE_THIS_VOLATILE (olddecl) = TREE_THIS_VOLATILE (newdecl);
13904       TREE_SIDE_EFFECTS (olddecl) = TREE_SIDE_EFFECTS (newdecl);
13905     }
13906
13907   /* Merge the storage class information.  */
13908   /* For functions, static overrides non-static.  */
13909   if (TREE_CODE (newdecl) == FUNCTION_DECL)
13910     {
13911       TREE_PUBLIC (newdecl) &= TREE_PUBLIC (olddecl);
13912       /* This is since we don't automatically
13913          copy the attributes of NEWDECL into OLDDECL.  */
13914       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13915       /* If this clears `static', clear it in the identifier too.  */
13916       if (! TREE_PUBLIC (olddecl))
13917         TREE_PUBLIC (DECL_NAME (olddecl)) = 0;
13918     }
13919   if (DECL_EXTERNAL (newdecl))
13920     {
13921       TREE_STATIC (newdecl) = TREE_STATIC (olddecl);
13922       DECL_EXTERNAL (newdecl) = DECL_EXTERNAL (olddecl);
13923       /* An extern decl does not override previous storage class.  */
13924       TREE_PUBLIC (newdecl) = TREE_PUBLIC (olddecl);
13925     }
13926   else
13927     {
13928       TREE_STATIC (olddecl) = TREE_STATIC (newdecl);
13929       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13930     }
13931
13932   /* If either decl says `inline', this fn is inline,
13933      unless its definition was passed already.  */
13934   if (DECL_INLINE (newdecl) && DECL_INITIAL (olddecl) == 0)
13935     DECL_INLINE (olddecl) = 1;
13936   DECL_INLINE (newdecl) = DECL_INLINE (olddecl);
13937
13938   /* Get rid of any built-in function if new arg types don't match it
13939      or if we have a function definition.  */
13940   if (TREE_CODE (newdecl) == FUNCTION_DECL
13941       && DECL_BUILT_IN (olddecl)
13942       && (!types_match || new_is_definition))
13943     {
13944       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13945       DECL_BUILT_IN_CLASS (olddecl) = NOT_BUILT_IN;
13946     }
13947
13948   /* If redeclaring a builtin function, and not a definition,
13949      it stays built in.
13950      Also preserve various other info from the definition.  */
13951   if (TREE_CODE (newdecl) == FUNCTION_DECL && !new_is_definition)
13952     {
13953       if (DECL_BUILT_IN (olddecl))
13954         {
13955           DECL_BUILT_IN_CLASS (newdecl) = DECL_BUILT_IN_CLASS (olddecl);
13956           DECL_FUNCTION_CODE (newdecl) = DECL_FUNCTION_CODE (olddecl);
13957         }
13958       else
13959         DECL_FRAME_SIZE (newdecl) = DECL_FRAME_SIZE (olddecl);
13960
13961       DECL_RESULT (newdecl) = DECL_RESULT (olddecl);
13962       DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13963       DECL_SAVED_INSNS (newdecl) = DECL_SAVED_INSNS (olddecl);
13964       DECL_ARGUMENTS (newdecl) = DECL_ARGUMENTS (olddecl);
13965     }
13966
13967   /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13968      But preserve olddecl's DECL_UID.  */
13969   {
13970     register unsigned olddecl_uid = DECL_UID (olddecl);
13971
13972     memcpy ((char *) olddecl + sizeof (struct tree_common),
13973             (char *) newdecl + sizeof (struct tree_common),
13974             sizeof (struct tree_decl) - sizeof (struct tree_common));
13975     DECL_UID (olddecl) = olddecl_uid;
13976   }
13977
13978   return 1;
13979 }
13980
13981 /* Finish processing of a declaration;
13982    install its initial value.
13983    If the length of an array type is not known before,
13984    it must be determined now, from the initial value, or it is an error.  */
13985
13986 static void
13987 finish_decl (tree decl, tree init, bool is_top_level)
13988 {
13989   register tree type = TREE_TYPE (decl);
13990   int was_incomplete = (DECL_SIZE (decl) == 0);
13991   int temporary = allocation_temporary_p ();
13992   bool at_top_level = (current_binding_level == global_binding_level);
13993   bool top_level = is_top_level || at_top_level;
13994
13995   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13996      level anyway.  */
13997   assert (!is_top_level || !at_top_level);
13998
13999   if (TREE_CODE (decl) == PARM_DECL)
14000     assert (init == NULL_TREE);
14001   /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
14002      overlaps DECL_ARG_TYPE.  */
14003   else if (init == NULL_TREE)
14004     assert (DECL_INITIAL (decl) == NULL_TREE);
14005   else
14006     assert (DECL_INITIAL (decl) == error_mark_node);
14007
14008   if (init != NULL_TREE)
14009     {
14010       if (TREE_CODE (decl) != TYPE_DECL)
14011         DECL_INITIAL (decl) = init;
14012       else
14013         {
14014           /* typedef foo = bar; store the type of bar as the type of foo.  */
14015           TREE_TYPE (decl) = TREE_TYPE (init);
14016           DECL_INITIAL (decl) = init = 0;
14017         }
14018     }
14019
14020   /* Pop back to the obstack that is current for this binding level. This is
14021      because MAXINDEX, rtl, etc. to be made below must go in the permanent
14022      obstack.  But don't discard the temporary data yet.  */
14023   pop_obstacks ();
14024
14025   /* Deduce size of array from initialization, if not already known */
14026
14027   if (TREE_CODE (type) == ARRAY_TYPE
14028       && TYPE_DOMAIN (type) == 0
14029       && TREE_CODE (decl) != TYPE_DECL)
14030     {
14031       assert (top_level);
14032       assert (was_incomplete);
14033
14034       layout_decl (decl, 0);
14035     }
14036
14037   if (TREE_CODE (decl) == VAR_DECL)
14038     {
14039       if (DECL_SIZE (decl) == NULL_TREE
14040           && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
14041         layout_decl (decl, 0);
14042
14043       if (DECL_SIZE (decl) == NULL_TREE
14044           && (TREE_STATIC (decl)
14045               ?
14046       /* A static variable with an incomplete type is an error if it is
14047          initialized. Also if it is not file scope. Otherwise, let it
14048          through, but if it is not `extern' then it may cause an error
14049          message later.  */
14050               (DECL_INITIAL (decl) != 0 || DECL_CONTEXT (decl) != 0)
14051               :
14052       /* An automatic variable with an incomplete type is an error.  */
14053               !DECL_EXTERNAL (decl)))
14054         {
14055           assert ("storage size not known" == NULL);
14056           abort ();
14057         }
14058
14059       if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
14060           && (DECL_SIZE (decl) != 0)
14061           && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
14062         {
14063           assert ("storage size not constant" == NULL);
14064           abort ();
14065         }
14066     }
14067
14068   /* Output the assembler code and/or RTL code for variables and functions,
14069      unless the type is an undefined structure or union. If not, it will get
14070      done when the type is completed.  */
14071
14072   if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL)
14073     {
14074       rest_of_decl_compilation (decl, NULL,
14075                                 DECL_CONTEXT (decl) == 0,
14076                                 0);
14077
14078       if (DECL_CONTEXT (decl) != 0)
14079         {
14080           /* Recompute the RTL of a local array now if it used to be an
14081              incomplete type.  */
14082           if (was_incomplete
14083               && !TREE_STATIC (decl) && !DECL_EXTERNAL (decl))
14084             {
14085               /* If we used it already as memory, it must stay in memory.  */
14086               TREE_ADDRESSABLE (decl) = TREE_USED (decl);
14087               /* If it's still incomplete now, no init will save it.  */
14088               if (DECL_SIZE (decl) == 0)
14089                 DECL_INITIAL (decl) = 0;
14090               expand_decl (decl);
14091             }
14092           /* Compute and store the initial value.  */
14093           if (TREE_CODE (decl) != FUNCTION_DECL)
14094             expand_decl_init (decl);
14095         }
14096     }
14097   else if (TREE_CODE (decl) == TYPE_DECL)
14098     {
14099       rest_of_decl_compilation (decl, NULL_PTR,
14100                                 DECL_CONTEXT (decl) == 0,
14101                                 0);
14102     }
14103
14104   if (!(TREE_CODE (decl) == FUNCTION_DECL && DECL_INLINE (decl))
14105       && temporary
14106   /* DECL_INITIAL is not defined in PARM_DECLs, since it shares space with
14107      DECL_ARG_TYPE.  */
14108       && TREE_CODE (decl) != PARM_DECL)
14109     {
14110       /* We need to remember that this array HAD an initialization, but
14111          discard the actual temporary nodes, since we can't have a permanent
14112          node keep pointing to them.  */
14113       /* We make an exception for inline functions, since it's normal for a
14114          local extern redeclaration of an inline function to have a copy of
14115          the top-level decl's DECL_INLINE.  */
14116       if ((DECL_INITIAL (decl) != 0)
14117           && (DECL_INITIAL (decl) != error_mark_node))
14118         {
14119           /* If this is a const variable, then preserve the
14120              initializer instead of discarding it so that we can optimize
14121              references to it.  */
14122           /* This test used to include TREE_STATIC, but this won't be set
14123              for function level initializers.  */
14124           if (TREE_READONLY (decl))
14125             {
14126               preserve_initializer ();
14127
14128               /* The initializer and DECL must have the same (or equivalent
14129                  types), but if the initializer is a STRING_CST, its type
14130                  might not be on the right obstack, so copy the type
14131                  of DECL.  */
14132               TREE_TYPE (DECL_INITIAL (decl)) = type;
14133             }
14134           else
14135             DECL_INITIAL (decl) = error_mark_node;
14136         }
14137     }
14138
14139   /* If we have gone back from temporary to permanent allocation, actually
14140      free the temporary space that we no longer need.  */
14141   if (temporary && !allocation_temporary_p ())
14142     permanent_allocation (0);
14143
14144   /* At the end of a declaration, throw away any variable type sizes of types
14145      defined inside that declaration.  There is no use computing them in the
14146      following function definition.  */
14147   if (current_binding_level == global_binding_level)
14148     get_pending_sizes ();
14149 }
14150
14151 /* Finish up a function declaration and compile that function
14152    all the way to assembler language output.  The free the storage
14153    for the function definition.
14154
14155    This is called after parsing the body of the function definition.
14156
14157    NESTED is nonzero if the function being finished is nested in another.  */
14158
14159 static void
14160 finish_function (int nested)
14161 {
14162   register tree fndecl = current_function_decl;
14163
14164   assert (fndecl != NULL_TREE);
14165   if (TREE_CODE (fndecl) != ERROR_MARK)
14166     {
14167       if (nested)
14168         assert (DECL_CONTEXT (fndecl) != NULL_TREE);
14169       else
14170         assert (DECL_CONTEXT (fndecl) == NULL_TREE);
14171     }
14172
14173 /*  TREE_READONLY (fndecl) = 1;
14174     This caused &foo to be of type ptr-to-const-function
14175     which then got a warning when stored in a ptr-to-function variable.  */
14176
14177   poplevel (1, 0, 1);
14178
14179   if (TREE_CODE (fndecl) != ERROR_MARK)
14180     {
14181       BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
14182
14183       /* Must mark the RESULT_DECL as being in this function.  */
14184
14185       DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
14186
14187       /* Obey `register' declarations if `setjmp' is called in this fn.  */
14188       /* Generate rtl for function exit.  */
14189       expand_function_end (input_filename, lineno, 0);
14190
14191       /* So we can tell if jump_optimize sets it to 1.  */
14192       can_reach_end = 0;
14193
14194       /* If this is a nested function, protect the local variables in the stack
14195          above us from being collected while we're compiling this function.  */
14196       if (ggc_p && nested)
14197         ggc_push_context ();
14198
14199       /* Run the optimizers and output the assembler code for this function.  */
14200       rest_of_compilation (fndecl);
14201
14202       /* Undo the GC context switch.  */
14203       if (ggc_p && nested)
14204         ggc_pop_context ();
14205     }
14206
14207   /* Free all the tree nodes making up this function.  */
14208   /* Switch back to allocating nodes permanently until we start another
14209      function.  */
14210   if (!nested)
14211     permanent_allocation (1);
14212
14213   if (TREE_CODE (fndecl) != ERROR_MARK
14214       && !nested
14215       && DECL_SAVED_INSNS (fndecl) == 0)
14216     {
14217       /* Stop pointing to the local nodes about to be freed.  */
14218       /* But DECL_INITIAL must remain nonzero so we know this was an actual
14219          function definition.  */
14220       /* For a nested function, this is done in pop_f_function_context.  */
14221       /* If rest_of_compilation set this to 0, leave it 0.  */
14222       if (DECL_INITIAL (fndecl) != 0)
14223         DECL_INITIAL (fndecl) = error_mark_node;
14224       DECL_ARGUMENTS (fndecl) = 0;
14225     }
14226
14227   if (!nested)
14228     {
14229       /* Let the error reporting routines know that we're outside a function.
14230          For a nested function, this value is used in pop_c_function_context
14231          and then reset via pop_function_context.  */
14232       ffecom_outer_function_decl_ = current_function_decl = NULL;
14233     }
14234 }
14235
14236 /* Plug-in replacement for identifying the name of a decl and, for a
14237    function, what we call it in diagnostics.  For now, "program unit"
14238    should suffice, since it's a bit of a hassle to figure out which
14239    of several kinds of things it is.  Note that it could conceivably
14240    be a statement function, which probably isn't really a program unit
14241    per se, but if that comes up, it should be easy to check (being a
14242    nested function and all).  */
14243
14244 static const char *
14245 lang_printable_name (tree decl, int v)
14246 {
14247   /* Just to keep GCC quiet about the unused variable.
14248      In theory, differing values of V should produce different
14249      output.  */
14250   switch (v)
14251     {
14252     default:
14253       if (TREE_CODE (decl) == ERROR_MARK)
14254         return "erroneous code";
14255       return IDENTIFIER_POINTER (DECL_NAME (decl));
14256     }
14257 }
14258
14259 /* g77's function to print out name of current function that caused
14260    an error.  */
14261
14262 #if BUILT_FOR_270
14263 static void
14264 lang_print_error_function (const char *file)
14265 {
14266   static ffeglobal last_g = NULL;
14267   static ffesymbol last_s = NULL;
14268   ffeglobal g;
14269   ffesymbol s;
14270   const char *kind;
14271
14272   if ((ffecom_primary_entry_ == NULL)
14273       || (ffesymbol_global (ffecom_primary_entry_) == NULL))
14274     {
14275       g = NULL;
14276       s = NULL;
14277       kind = NULL;
14278     }
14279   else
14280     {
14281       g = ffesymbol_global (ffecom_primary_entry_);
14282       if (ffecom_nested_entry_ == NULL)
14283         {
14284           s = ffecom_primary_entry_;
14285           switch (ffesymbol_kind (s))
14286             {
14287             case FFEINFO_kindFUNCTION:
14288               kind = "function";
14289               break;
14290
14291             case FFEINFO_kindSUBROUTINE:
14292               kind = "subroutine";
14293               break;
14294
14295             case FFEINFO_kindPROGRAM:
14296               kind = "program";
14297               break;
14298
14299             case FFEINFO_kindBLOCKDATA:
14300               kind = "block-data";
14301               break;
14302
14303             default:
14304               kind = ffeinfo_kind_message (ffesymbol_kind (s));
14305               break;
14306             }
14307         }
14308       else
14309         {
14310           s = ffecom_nested_entry_;
14311           kind = "statement function";
14312         }
14313     }
14314
14315   if ((last_g != g) || (last_s != s))
14316     {
14317       if (file)
14318         fprintf (stderr, "%s: ", file);
14319
14320       if (s == NULL)
14321         fprintf (stderr, "Outside of any program unit:\n");
14322       else
14323         {
14324           const char *name = ffesymbol_text (s);
14325
14326           fprintf (stderr, "In %s `%s':\n", kind, name);
14327         }
14328
14329       last_g = g;
14330       last_s = s;
14331     }
14332 }
14333 #endif
14334
14335 /* Similar to `lookup_name' but look only at current binding level.  */
14336
14337 static tree
14338 lookup_name_current_level (tree name)
14339 {
14340   register tree t;
14341
14342   if (current_binding_level == global_binding_level)
14343     return IDENTIFIER_GLOBAL_VALUE (name);
14344
14345   if (IDENTIFIER_LOCAL_VALUE (name) == 0)
14346     return 0;
14347
14348   for (t = current_binding_level->names; t; t = TREE_CHAIN (t))
14349     if (DECL_NAME (t) == name)
14350       break;
14351
14352   return t;
14353 }
14354
14355 /* Create a new `struct binding_level'.  */
14356
14357 static struct binding_level *
14358 make_binding_level ()
14359 {
14360   /* NOSTRICT */
14361   return (struct binding_level *) xmalloc (sizeof (struct binding_level));
14362 }
14363
14364 /* Save and restore the variables in this file and elsewhere
14365    that keep track of the progress of compilation of the current function.
14366    Used for nested functions.  */
14367
14368 struct f_function
14369 {
14370   struct f_function *next;
14371   tree named_labels;
14372   tree shadowed_labels;
14373   struct binding_level *binding_level;
14374 };
14375
14376 struct f_function *f_function_chain;
14377
14378 /* Restore the variables used during compilation of a C function.  */
14379
14380 static void
14381 pop_f_function_context ()
14382 {
14383   struct f_function *p = f_function_chain;
14384   tree link;
14385
14386   /* Bring back all the labels that were shadowed.  */
14387   for (link = shadowed_labels; link; link = TREE_CHAIN (link))
14388     if (DECL_NAME (TREE_VALUE (link)) != 0)
14389       IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link)))
14390         = TREE_VALUE (link);
14391
14392   if (current_function_decl != error_mark_node
14393       && DECL_SAVED_INSNS (current_function_decl) == 0)
14394     {
14395       /* Stop pointing to the local nodes about to be freed.  */
14396       /* But DECL_INITIAL must remain nonzero so we know this was an actual
14397          function definition.  */
14398       DECL_INITIAL (current_function_decl) = error_mark_node;
14399       DECL_ARGUMENTS (current_function_decl) = 0;
14400     }
14401
14402   pop_function_context ();
14403
14404   f_function_chain = p->next;
14405
14406   named_labels = p->named_labels;
14407   shadowed_labels = p->shadowed_labels;
14408   current_binding_level = p->binding_level;
14409
14410   free (p);
14411 }
14412
14413 /* Save and reinitialize the variables
14414    used during compilation of a C function.  */
14415
14416 static void
14417 push_f_function_context ()
14418 {
14419   struct f_function *p
14420   = (struct f_function *) xmalloc (sizeof (struct f_function));
14421
14422   push_function_context ();
14423
14424   p->next = f_function_chain;
14425   f_function_chain = p;
14426
14427   p->named_labels = named_labels;
14428   p->shadowed_labels = shadowed_labels;
14429   p->binding_level = current_binding_level;
14430 }
14431
14432 static void
14433 push_parm_decl (tree parm)
14434 {
14435   int old_immediate_size_expand = immediate_size_expand;
14436
14437   /* Don't try computing parm sizes now -- wait till fn is called.  */
14438
14439   immediate_size_expand = 0;
14440
14441   push_obstacks_nochange ();
14442
14443   /* Fill in arg stuff.  */
14444
14445   DECL_ARG_TYPE (parm) = TREE_TYPE (parm);
14446   DECL_ARG_TYPE_AS_WRITTEN (parm) = TREE_TYPE (parm);
14447   TREE_READONLY (parm) = 1;     /* All implementation args are read-only. */
14448
14449   parm = pushdecl (parm);
14450
14451   immediate_size_expand = old_immediate_size_expand;
14452
14453   finish_decl (parm, NULL_TREE, FALSE);
14454 }
14455
14456 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate.  */
14457
14458 static tree
14459 pushdecl_top_level (x)
14460      tree x;
14461 {
14462   register tree t;
14463   register struct binding_level *b = current_binding_level;
14464   register tree f = current_function_decl;
14465
14466   current_binding_level = global_binding_level;
14467   current_function_decl = NULL_TREE;
14468   t = pushdecl (x);
14469   current_binding_level = b;
14470   current_function_decl = f;
14471   return t;
14472 }
14473
14474 /* Store the list of declarations of the current level.
14475    This is done for the parameter declarations of a function being defined,
14476    after they are modified in the light of any missing parameters.  */
14477
14478 static tree
14479 storedecls (decls)
14480      tree decls;
14481 {
14482   return current_binding_level->names = decls;
14483 }
14484
14485 /* Store the parameter declarations into the current function declaration.
14486    This is called after parsing the parameter declarations, before
14487    digesting the body of the function.
14488
14489    For an old-style definition, modify the function's type
14490    to specify at least the number of arguments.  */
14491
14492 static void
14493 store_parm_decls (int is_main_program UNUSED)
14494 {
14495   register tree fndecl = current_function_decl;
14496
14497   if (fndecl == error_mark_node)
14498     return;
14499
14500   /* This is a chain of PARM_DECLs from old-style parm declarations.  */
14501   DECL_ARGUMENTS (fndecl) = storedecls (nreverse (getdecls ()));
14502
14503   /* Initialize the RTL code for the function.  */
14504
14505   init_function_start (fndecl, input_filename, lineno);
14506
14507   /* Set up parameters and prepare for return, for the function.  */
14508
14509   expand_function_start (fndecl, 0);
14510 }
14511
14512 static tree
14513 start_decl (tree decl, bool is_top_level)
14514 {
14515   register tree tem;
14516   bool at_top_level = (current_binding_level == global_binding_level);
14517   bool top_level = is_top_level || at_top_level;
14518
14519   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
14520      level anyway.  */
14521   assert (!is_top_level || !at_top_level);
14522
14523   /* The corresponding pop_obstacks is in finish_decl.  */
14524   push_obstacks_nochange ();
14525
14526   if (DECL_INITIAL (decl) != NULL_TREE)
14527     {
14528       assert (DECL_INITIAL (decl) == error_mark_node);
14529       assert (!DECL_EXTERNAL (decl));
14530     }
14531   else if (top_level)
14532     assert ((TREE_STATIC (decl) == 1) || DECL_EXTERNAL (decl) == 1);
14533
14534   /* For Fortran, we by default put things in .common when possible.  */
14535   DECL_COMMON (decl) = 1;
14536
14537   /* Add this decl to the current binding level. TEM may equal DECL or it may
14538      be a previous decl of the same name.  */
14539   if (is_top_level)
14540     tem = pushdecl_top_level (decl);
14541   else
14542     tem = pushdecl (decl);
14543
14544   /* For a local variable, define the RTL now.  */
14545   if (!top_level
14546   /* But not if this is a duplicate decl and we preserved the rtl from the
14547      previous one (which may or may not happen).  */
14548       && DECL_RTL (tem) == 0)
14549     {
14550       if (TYPE_SIZE (TREE_TYPE (tem)) != 0)
14551         expand_decl (tem);
14552       else if (TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE
14553                && DECL_INITIAL (tem) != 0)
14554         expand_decl (tem);
14555     }
14556
14557   if (DECL_INITIAL (tem) != NULL_TREE)
14558     {
14559       /* When parsing and digesting the initializer, use temporary storage.
14560          Do this even if we will ignore the value.  */
14561       if (at_top_level)
14562         temporary_allocation ();
14563     }
14564
14565   return tem;
14566 }
14567
14568 /* Create the FUNCTION_DECL for a function definition.
14569    DECLSPECS and DECLARATOR are the parts of the declaration;
14570    they describe the function's name and the type it returns,
14571    but twisted together in a fashion that parallels the syntax of C.
14572
14573    This function creates a binding context for the function body
14574    as well as setting up the FUNCTION_DECL in current_function_decl.
14575
14576    Returns 1 on success.  If the DECLARATOR is not suitable for a function
14577    (it defines a datum instead), we return 0, which tells
14578    yyparse to report a parse error.
14579
14580    NESTED is nonzero for a function nested within another function.  */
14581
14582 static void
14583 start_function (tree name, tree type, int nested, int public)
14584 {
14585   tree decl1;
14586   tree restype;
14587   int old_immediate_size_expand = immediate_size_expand;
14588
14589   named_labels = 0;
14590   shadowed_labels = 0;
14591
14592   /* Don't expand any sizes in the return type of the function.  */
14593   immediate_size_expand = 0;
14594
14595   if (nested)
14596     {
14597       assert (!public);
14598       assert (current_function_decl != NULL_TREE);
14599       assert (DECL_CONTEXT (current_function_decl) == NULL_TREE);
14600     }
14601   else
14602     {
14603       assert (current_function_decl == NULL_TREE);
14604     }
14605
14606   if (TREE_CODE (type) == ERROR_MARK)
14607     decl1 = current_function_decl = error_mark_node;
14608   else
14609     {
14610       decl1 = build_decl (FUNCTION_DECL,
14611                           name,
14612                           type);
14613       TREE_PUBLIC (decl1) = public ? 1 : 0;
14614       if (nested)
14615         DECL_INLINE (decl1) = 1;
14616       TREE_STATIC (decl1) = 1;
14617       DECL_EXTERNAL (decl1) = 0;
14618
14619       announce_function (decl1);
14620
14621       /* Make the init_value nonzero so pushdecl knows this is not tentative.
14622          error_mark_node is replaced below (in poplevel) with the BLOCK.  */
14623       DECL_INITIAL (decl1) = error_mark_node;
14624
14625       /* Record the decl so that the function name is defined. If we already have
14626          a decl for this name, and it is a FUNCTION_DECL, use the old decl.  */
14627
14628       current_function_decl = pushdecl (decl1);
14629     }
14630
14631   if (!nested)
14632     ffecom_outer_function_decl_ = current_function_decl;
14633
14634   pushlevel (0);
14635   current_binding_level->prep_state = 2;
14636
14637   if (TREE_CODE (current_function_decl) != ERROR_MARK)
14638     {
14639       make_function_rtl (current_function_decl);
14640
14641       restype = TREE_TYPE (TREE_TYPE (current_function_decl));
14642       DECL_RESULT (current_function_decl)
14643         = build_decl (RESULT_DECL, NULL_TREE, restype);
14644     }
14645
14646   if (!nested)
14647     /* Allocate further tree nodes temporarily during compilation of this
14648        function only.  */
14649     temporary_allocation ();
14650
14651   if (!nested && (TREE_CODE (current_function_decl) != ERROR_MARK))
14652     TREE_ADDRESSABLE (current_function_decl) = 1;
14653
14654   immediate_size_expand = old_immediate_size_expand;
14655 }
14656 \f
14657 /* Here are the public functions the GNU back end needs.  */
14658
14659 tree
14660 convert (type, expr)
14661      tree type, expr;
14662 {
14663   register tree e = expr;
14664   register enum tree_code code = TREE_CODE (type);
14665
14666   if (type == TREE_TYPE (e)
14667       || TREE_CODE (e) == ERROR_MARK)
14668     return e;
14669   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
14670     return fold (build1 (NOP_EXPR, type, e));
14671   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
14672       || code == ERROR_MARK)
14673     return error_mark_node;
14674   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
14675     {
14676       assert ("void value not ignored as it ought to be" == NULL);
14677       return error_mark_node;
14678     }
14679   if (code == VOID_TYPE)
14680     return build1 (CONVERT_EXPR, type, e);
14681   if ((code != RECORD_TYPE)
14682       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
14683     e = ffecom_1 (REALPART_EXPR, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))),
14684                   e);
14685   if (code == INTEGER_TYPE || code == ENUMERAL_TYPE)
14686     return fold (convert_to_integer (type, e));
14687   if (code == POINTER_TYPE)
14688     return fold (convert_to_pointer (type, e));
14689   if (code == REAL_TYPE)
14690     return fold (convert_to_real (type, e));
14691   if (code == COMPLEX_TYPE)
14692     return fold (convert_to_complex (type, e));
14693   if (code == RECORD_TYPE)
14694     return fold (ffecom_convert_to_complex_ (type, e));
14695
14696   assert ("conversion to non-scalar type requested" == NULL);
14697   return error_mark_node;
14698 }
14699
14700 /* integrate_decl_tree calls this function, but since we don't use the
14701    DECL_LANG_SPECIFIC field, this is a no-op.  */
14702
14703 void
14704 copy_lang_decl (node)
14705      tree node UNUSED;
14706 {
14707 }
14708
14709 /* Return the list of declarations of the current level.
14710    Note that this list is in reverse order unless/until
14711    you nreverse it; and when you do nreverse it, you must
14712    store the result back using `storedecls' or you will lose.  */
14713
14714 tree
14715 getdecls ()
14716 {
14717   return current_binding_level->names;
14718 }
14719
14720 /* Nonzero if we are currently in the global binding level.  */
14721
14722 int
14723 global_bindings_p ()
14724 {
14725   return current_binding_level == global_binding_level;
14726 }
14727
14728 /* Print an error message for invalid use of an incomplete type.
14729    VALUE is the expression that was used (or 0 if that isn't known)
14730    and TYPE is the type that was invalid.  */
14731
14732 void
14733 incomplete_type_error (value, type)
14734      tree value UNUSED;
14735      tree type;
14736 {
14737   if (TREE_CODE (type) == ERROR_MARK)
14738     return;
14739
14740   assert ("incomplete type?!?" == NULL);
14741 }
14742
14743 /* Mark ARG for GC.  */
14744 static void
14745 mark_binding_level (void *arg)
14746 {
14747   struct binding_level *level = *(struct binding_level **) arg;
14748
14749   while (level)
14750     {
14751       ggc_mark_tree (level->names);
14752       ggc_mark_tree (level->blocks);
14753       ggc_mark_tree (level->this_block);
14754       level = level->level_chain;
14755     }
14756 }
14757
14758 void
14759 init_decl_processing ()
14760 {
14761   static tree *const tree_roots[] = {
14762     &current_function_decl,
14763     &string_type_node,
14764     &ffecom_tree_fun_type_void,
14765     &ffecom_integer_zero_node,
14766     &ffecom_integer_one_node,
14767     &ffecom_tree_subr_type,
14768     &ffecom_tree_ptr_to_subr_type,
14769     &ffecom_tree_blockdata_type,
14770     &ffecom_tree_xargc_,
14771     &ffecom_f2c_integer_type_node,
14772     &ffecom_f2c_ptr_to_integer_type_node,
14773     &ffecom_f2c_address_type_node,
14774     &ffecom_f2c_real_type_node,
14775     &ffecom_f2c_ptr_to_real_type_node,
14776     &ffecom_f2c_doublereal_type_node,
14777     &ffecom_f2c_complex_type_node,
14778     &ffecom_f2c_doublecomplex_type_node,
14779     &ffecom_f2c_longint_type_node,
14780     &ffecom_f2c_logical_type_node,
14781     &ffecom_f2c_flag_type_node,
14782     &ffecom_f2c_ftnlen_type_node,
14783     &ffecom_f2c_ftnlen_zero_node,
14784     &ffecom_f2c_ftnlen_one_node,
14785     &ffecom_f2c_ftnlen_two_node,
14786     &ffecom_f2c_ptr_to_ftnlen_type_node,
14787     &ffecom_f2c_ftnint_type_node,
14788     &ffecom_f2c_ptr_to_ftnint_type_node,
14789     &ffecom_outer_function_decl_,
14790     &ffecom_previous_function_decl_,
14791     &ffecom_which_entrypoint_decl_,
14792     &ffecom_float_zero_,
14793     &ffecom_float_half_,
14794     &ffecom_double_zero_,
14795     &ffecom_double_half_,
14796     &ffecom_func_result_,
14797     &ffecom_func_length_,
14798     &ffecom_multi_type_node_,
14799     &ffecom_multi_retval_,
14800     &named_labels,
14801     &shadowed_labels
14802   };
14803   size_t i;
14804
14805   malloc_init ();
14806
14807   /* Record our roots.  */
14808   for (i = 0; i < ARRAY_SIZE (tree_roots); i++)
14809     ggc_add_tree_root (tree_roots[i], 1);
14810   ggc_add_tree_root (&ffecom_tree_type[0][0],
14811                      FFEINFO_basictype*FFEINFO_kindtype);
14812   ggc_add_tree_root (&ffecom_tree_fun_type[0][0],
14813                      FFEINFO_basictype*FFEINFO_kindtype);
14814   ggc_add_tree_root (&ffecom_tree_ptr_to_fun_type[0][0],
14815                      FFEINFO_basictype*FFEINFO_kindtype);
14816   ggc_add_tree_root (ffecom_gfrt_, FFECOM_gfrt);
14817   ggc_add_root (&current_binding_level, 1, sizeof current_binding_level,
14818                 mark_binding_level);
14819   ggc_add_root (&free_binding_level, 1, sizeof current_binding_level,
14820                 mark_binding_level);
14821   ggc_add_root (&tracker_head, 1, sizeof tracker_head, mark_tracker_head);
14822
14823   ffe_init_0 ();
14824 }
14825
14826 const char *
14827 init_parse (filename)
14828      const char *filename;
14829 {
14830   /* Open input file.  */
14831   if (filename == 0 || !strcmp (filename, "-"))
14832     {
14833       finput = stdin;
14834       filename = "stdin";
14835     }
14836   else
14837     finput = fopen (filename, "r");
14838   if (finput == 0)
14839     pfatal_with_name (filename);
14840
14841 #ifdef IO_BUFFER_SIZE
14842   setvbuf (finput, (char *) xmalloc (IO_BUFFER_SIZE), _IOFBF, IO_BUFFER_SIZE);
14843 #endif
14844
14845   /* Make identifier nodes long enough for the language-specific slots.  */
14846   set_identifier_size (sizeof (struct lang_identifier));
14847   decl_printable_name = lang_printable_name;
14848 #if BUILT_FOR_270
14849   print_error_function = lang_print_error_function;
14850 #endif
14851
14852   return filename;
14853 }
14854
14855 void
14856 finish_parse ()
14857 {
14858   fclose (finput);
14859 }
14860
14861 /* Delete the node BLOCK from the current binding level.
14862    This is used for the block inside a stmt expr ({...})
14863    so that the block can be reinserted where appropriate.  */
14864
14865 static void
14866 delete_block (block)
14867      tree block;
14868 {
14869   tree t;
14870   if (current_binding_level->blocks == block)
14871     current_binding_level->blocks = TREE_CHAIN (block);
14872   for (t = current_binding_level->blocks; t;)
14873     {
14874       if (TREE_CHAIN (t) == block)
14875         TREE_CHAIN (t) = TREE_CHAIN (block);
14876       else
14877         t = TREE_CHAIN (t);
14878     }
14879   TREE_CHAIN (block) = NULL;
14880   /* Clear TREE_USED which is always set by poplevel.
14881      The flag is set again if insert_block is called.  */
14882   TREE_USED (block) = 0;
14883 }
14884
14885 void
14886 insert_block (block)
14887      tree block;
14888 {
14889   TREE_USED (block) = 1;
14890   current_binding_level->blocks
14891     = chainon (current_binding_level->blocks, block);
14892 }
14893
14894 int
14895 lang_decode_option (argc, argv)
14896      int argc;
14897      char **argv;
14898 {
14899   return ffe_decode_option (argc, argv);
14900 }
14901
14902 /* used by print-tree.c */
14903
14904 void
14905 lang_print_xnode (file, node, indent)
14906      FILE *file UNUSED;
14907      tree node UNUSED;
14908      int indent UNUSED;
14909 {
14910 }
14911
14912 void
14913 lang_finish ()
14914 {
14915   ffe_terminate_0 ();
14916
14917   if (ffe_is_ffedebug ())
14918     malloc_pool_display (malloc_pool_image ());
14919 }
14920
14921 const char *
14922 lang_identify ()
14923 {
14924   return "f77";
14925 }
14926
14927 /* Return the typed-based alias set for T, which may be an expression
14928    or a type.  Return -1 if we don't do anything special.  */
14929
14930 HOST_WIDE_INT
14931 lang_get_alias_set (t)
14932      tree t ATTRIBUTE_UNUSED;
14933 {
14934   /* We do not wish to use alias-set based aliasing at all.  Used in the
14935      extreme (every object with its own set, with equivalences recorded)
14936      it might be helpful, but there are problems when it comes to inlining.
14937      We get on ok with flag_argument_noalias, and alias-set aliasing does
14938      currently limit how stack slots can be reused, which is a lose.  */
14939   return 0;
14940 }
14941
14942 void
14943 lang_init_options ()
14944 {
14945   /* Set default options for Fortran.  */
14946   flag_move_all_movables = 1;
14947   flag_reduce_all_givs = 1;
14948   flag_argument_noalias = 2;
14949   flag_errno_math = 0;
14950   flag_complex_divide_method = 1;
14951 }
14952
14953 void
14954 lang_init ()
14955 {
14956   /* If the file is output from cpp, it should contain a first line
14957      `# 1 "real-filename"', and the current design of gcc (toplev.c
14958      in particular and the way it sets up information relied on by
14959      INCLUDE) requires that we read this now, and store the
14960      "real-filename" info in master_input_filename.  Ask the lexer
14961      to try doing this.  */
14962   ffelex_hash_kludge (finput);
14963 }
14964
14965 int
14966 mark_addressable (exp)
14967      tree exp;
14968 {
14969   register tree x = exp;
14970   while (1)
14971     switch (TREE_CODE (x))
14972       {
14973       case ADDR_EXPR:
14974       case COMPONENT_REF:
14975       case ARRAY_REF:
14976         x = TREE_OPERAND (x, 0);
14977         break;
14978
14979       case CONSTRUCTOR:
14980         TREE_ADDRESSABLE (x) = 1;
14981         return 1;
14982
14983       case VAR_DECL:
14984       case CONST_DECL:
14985       case PARM_DECL:
14986       case RESULT_DECL:
14987         if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)
14988             && DECL_NONLOCAL (x))
14989           {
14990             if (TREE_PUBLIC (x))
14991               {
14992                 assert ("address of global register var requested" == NULL);
14993                 return 0;
14994               }
14995             assert ("address of register variable requested" == NULL);
14996           }
14997         else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
14998           {
14999             if (TREE_PUBLIC (x))
15000               {
15001                 assert ("address of global register var requested" == NULL);
15002                 return 0;
15003               }
15004             assert ("address of register var requested" == NULL);
15005           }
15006         put_var_into_stack (x);
15007
15008         /* drops in */
15009       case FUNCTION_DECL:
15010         TREE_ADDRESSABLE (x) = 1;
15011 #if 0                           /* poplevel deals with this now.  */
15012         if (DECL_CONTEXT (x) == 0)
15013           TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1;
15014 #endif
15015
15016       default:
15017         return 1;
15018       }
15019 }
15020
15021 /* If DECL has a cleanup, build and return that cleanup here.
15022    This is a callback called by expand_expr.  */
15023
15024 tree
15025 maybe_build_cleanup (decl)
15026      tree decl UNUSED;
15027 {
15028   /* There are no cleanups in Fortran.  */
15029   return NULL_TREE;
15030 }
15031
15032 /* Exit a binding level.
15033    Pop the level off, and restore the state of the identifier-decl mappings
15034    that were in effect when this level was entered.
15035
15036    If KEEP is nonzero, this level had explicit declarations, so
15037    and create a "block" (a BLOCK node) for the level
15038    to record its declarations and subblocks for symbol table output.
15039
15040    If FUNCTIONBODY is nonzero, this level is the body of a function,
15041    so create a block as if KEEP were set and also clear out all
15042    label names.
15043
15044    If REVERSE is nonzero, reverse the order of decls before putting
15045    them into the BLOCK.  */
15046
15047 tree
15048 poplevel (keep, reverse, functionbody)
15049      int keep;
15050      int reverse;
15051      int functionbody;
15052 {
15053   register tree link;
15054   /* The chain of decls was accumulated in reverse order.
15055      Put it into forward order, just for cleanliness.  */
15056   tree decls;
15057   tree subblocks = current_binding_level->blocks;
15058   tree block = 0;
15059   tree decl;
15060   int block_previously_created;
15061
15062   /* Get the decls in the order they were written.
15063      Usually current_binding_level->names is in reverse order.
15064      But parameter decls were previously put in forward order.  */
15065
15066   if (reverse)
15067     current_binding_level->names
15068       = decls = nreverse (current_binding_level->names);
15069   else
15070     decls = current_binding_level->names;
15071
15072   /* Output any nested inline functions within this block
15073      if they weren't already output.  */
15074
15075   for (decl = decls; decl; decl = TREE_CHAIN (decl))
15076     if (TREE_CODE (decl) == FUNCTION_DECL
15077         && ! TREE_ASM_WRITTEN (decl)
15078         && DECL_INITIAL (decl) != 0
15079         && TREE_ADDRESSABLE (decl))
15080       {
15081         /* If this decl was copied from a file-scope decl
15082            on account of a block-scope extern decl,
15083            propagate TREE_ADDRESSABLE to the file-scope decl.
15084
15085            DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
15086            true, since then the decl goes through save_for_inline_copying.  */
15087         if (DECL_ABSTRACT_ORIGIN (decl) != 0
15088             && DECL_ABSTRACT_ORIGIN (decl) != decl)
15089           TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1;
15090         else if (DECL_SAVED_INSNS (decl) != 0)
15091           {
15092             push_function_context ();
15093             output_inline_function (decl);
15094             pop_function_context ();
15095           }
15096       }
15097
15098   /* If there were any declarations or structure tags in that level,
15099      or if this level is a function body,
15100      create a BLOCK to record them for the life of this function.  */
15101
15102   block = 0;
15103   block_previously_created = (current_binding_level->this_block != 0);
15104   if (block_previously_created)
15105     block = current_binding_level->this_block;
15106   else if (keep || functionbody)
15107     block = make_node (BLOCK);
15108   if (block != 0)
15109     {
15110       BLOCK_VARS (block) = decls;
15111       BLOCK_SUBBLOCKS (block) = subblocks;
15112     }
15113
15114   /* In each subblock, record that this is its superior.  */
15115
15116   for (link = subblocks; link; link = TREE_CHAIN (link))
15117     BLOCK_SUPERCONTEXT (link) = block;
15118
15119   /* Clear out the meanings of the local variables of this level.  */
15120
15121   for (link = decls; link; link = TREE_CHAIN (link))
15122     {
15123       if (DECL_NAME (link) != 0)
15124         {
15125           /* If the ident. was used or addressed via a local extern decl,
15126              don't forget that fact.  */
15127           if (DECL_EXTERNAL (link))
15128             {
15129               if (TREE_USED (link))
15130                 TREE_USED (DECL_NAME (link)) = 1;
15131               if (TREE_ADDRESSABLE (link))
15132                 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link)) = 1;
15133             }
15134           IDENTIFIER_LOCAL_VALUE (DECL_NAME (link)) = 0;
15135         }
15136     }
15137
15138   /* If the level being exited is the top level of a function,
15139      check over all the labels, and clear out the current
15140      (function local) meanings of their names.  */
15141
15142   if (functionbody)
15143     {
15144       /* If this is the top level block of a function,
15145          the vars are the function's parameters.
15146          Don't leave them in the BLOCK because they are
15147          found in the FUNCTION_DECL instead.  */
15148
15149       BLOCK_VARS (block) = 0;
15150     }
15151
15152   /* Pop the current level, and free the structure for reuse.  */
15153
15154   {
15155     register struct binding_level *level = current_binding_level;
15156     current_binding_level = current_binding_level->level_chain;
15157
15158     level->level_chain = free_binding_level;
15159     free_binding_level = level;
15160   }
15161
15162   /* Dispose of the block that we just made inside some higher level.  */
15163   if (functionbody
15164       && current_function_decl != error_mark_node)
15165     DECL_INITIAL (current_function_decl) = block;
15166   else if (block)
15167     {
15168       if (!block_previously_created)
15169         current_binding_level->blocks
15170           = chainon (current_binding_level->blocks, block);
15171     }
15172   /* If we did not make a block for the level just exited,
15173      any blocks made for inner levels
15174      (since they cannot be recorded as subblocks in that level)
15175      must be carried forward so they will later become subblocks
15176      of something else.  */
15177   else if (subblocks)
15178     current_binding_level->blocks
15179       = chainon (current_binding_level->blocks, subblocks);
15180
15181   if (block)
15182     TREE_USED (block) = 1;
15183   return block;
15184 }
15185
15186 void
15187 print_lang_decl (file, node, indent)
15188      FILE *file UNUSED;
15189      tree node UNUSED;
15190      int indent UNUSED;
15191 {
15192 }
15193
15194 void
15195 print_lang_identifier (file, node, indent)
15196      FILE *file;
15197      tree node;
15198      int indent;
15199 {
15200   print_node (file, "global", IDENTIFIER_GLOBAL_VALUE (node), indent + 4);
15201   print_node (file, "local", IDENTIFIER_LOCAL_VALUE (node), indent + 4);
15202 }
15203
15204 void
15205 print_lang_statistics ()
15206 {
15207 }
15208
15209 void
15210 print_lang_type (file, node, indent)
15211      FILE *file UNUSED;
15212      tree node UNUSED;
15213      int indent UNUSED;
15214 {
15215 }
15216
15217 /* Record a decl-node X as belonging to the current lexical scope.
15218    Check for errors (such as an incompatible declaration for the same
15219    name already seen in the same scope).
15220
15221    Returns either X or an old decl for the same name.
15222    If an old decl is returned, it may have been smashed
15223    to agree with what X says.  */
15224
15225 tree
15226 pushdecl (x)
15227      tree x;
15228 {
15229   register tree t;
15230   register tree name = DECL_NAME (x);
15231   register struct binding_level *b = current_binding_level;
15232
15233   if ((TREE_CODE (x) == FUNCTION_DECL)
15234       && (DECL_INITIAL (x) == 0)
15235       && DECL_EXTERNAL (x))
15236     DECL_CONTEXT (x) = NULL_TREE;
15237   else
15238     DECL_CONTEXT (x) = current_function_decl;
15239
15240   if (name)
15241     {
15242       if (IDENTIFIER_INVENTED (name))
15243         {
15244 #if BUILT_FOR_270
15245           DECL_ARTIFICIAL (x) = 1;
15246 #endif
15247           DECL_IN_SYSTEM_HEADER (x) = 1;
15248         }
15249
15250       t = lookup_name_current_level (name);
15251
15252       assert ((t == NULL_TREE) || (DECL_CONTEXT (x) == NULL_TREE));
15253
15254       /* Don't push non-parms onto list for parms until we understand
15255          why we're doing this and whether it works.  */
15256
15257       assert ((b == global_binding_level)
15258               || !ffecom_transform_only_dummies_
15259               || TREE_CODE (x) == PARM_DECL);
15260
15261       if ((t != NULL_TREE) && duplicate_decls (x, t))
15262         return t;
15263
15264       /* If we are processing a typedef statement, generate a whole new
15265          ..._TYPE node (which will be just an variant of the existing
15266          ..._TYPE node with identical properties) and then install the
15267          TYPE_DECL node generated to represent the typedef name as the
15268          TYPE_NAME of this brand new (duplicate) ..._TYPE node.
15269
15270          The whole point here is to end up with a situation where each and every
15271          ..._TYPE node the compiler creates will be uniquely associated with
15272          AT MOST one node representing a typedef name. This way, even though
15273          the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
15274          (i.e. "typedef name") nodes very early on, later parts of the
15275          compiler can always do the reverse translation and get back the
15276          corresponding typedef name.  For example, given:
15277
15278          typedef struct S MY_TYPE; MY_TYPE object;
15279
15280          Later parts of the compiler might only know that `object' was of type
15281          `struct S' if it were not for code just below.  With this code
15282          however, later parts of the compiler see something like:
15283
15284          struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
15285
15286          And they can then deduce (from the node for type struct S') that the
15287          original object declaration was:
15288
15289          MY_TYPE object;
15290
15291          Being able to do this is important for proper support of protoize, and
15292          also for generating precise symbolic debugging information which
15293          takes full account of the programmer's (typedef) vocabulary.
15294
15295          Obviously, we don't want to generate a duplicate ..._TYPE node if the
15296          TYPE_DECL node that we are now processing really represents a
15297          standard built-in type.
15298
15299          Since all standard types are effectively declared at line zero in the
15300          source file, we can easily check to see if we are working on a
15301          standard type by checking the current value of lineno.  */
15302
15303       if (TREE_CODE (x) == TYPE_DECL)
15304         {
15305           if (DECL_SOURCE_LINE (x) == 0)
15306             {
15307               if (TYPE_NAME (TREE_TYPE (x)) == 0)
15308                 TYPE_NAME (TREE_TYPE (x)) = x;
15309             }
15310           else if (TREE_TYPE (x) != error_mark_node)
15311             {
15312               tree tt = TREE_TYPE (x);
15313
15314               tt = build_type_copy (tt);
15315               TYPE_NAME (tt) = x;
15316               TREE_TYPE (x) = tt;
15317             }
15318         }
15319
15320       /* This name is new in its binding level. Install the new declaration
15321          and return it.  */
15322       if (b == global_binding_level)
15323         IDENTIFIER_GLOBAL_VALUE (name) = x;
15324       else
15325         IDENTIFIER_LOCAL_VALUE (name) = x;
15326     }
15327
15328   /* Put decls on list in reverse order. We will reverse them later if
15329      necessary.  */
15330   TREE_CHAIN (x) = b->names;
15331   b->names = x;
15332
15333   return x;
15334 }
15335
15336 /* Nonzero if the current level needs to have a BLOCK made.  */
15337
15338 static int
15339 kept_level_p ()
15340 {
15341   tree decl;
15342
15343   for (decl = current_binding_level->names;
15344        decl;
15345        decl = TREE_CHAIN (decl))
15346     {
15347       if (TREE_USED (decl) || TREE_CODE (decl) != VAR_DECL
15348           || (DECL_NAME (decl) && ! DECL_ARTIFICIAL (decl)))
15349         /* Currently, there aren't supposed to be non-artificial names
15350            at other than the top block for a function -- they're
15351            believed to always be temps.  But it's wise to check anyway.  */
15352         return 1;
15353     }
15354   return 0;
15355 }
15356
15357 /* Enter a new binding level.
15358    If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
15359    not for that of tags.  */
15360
15361 void
15362 pushlevel (tag_transparent)
15363      int tag_transparent;
15364 {
15365   register struct binding_level *newlevel = NULL_BINDING_LEVEL;
15366
15367   assert (! tag_transparent);
15368
15369   if (current_binding_level == global_binding_level)
15370     {
15371       named_labels = 0;
15372     }
15373
15374   /* Reuse or create a struct for this binding level.  */
15375
15376   if (free_binding_level)
15377     {
15378       newlevel = free_binding_level;
15379       free_binding_level = free_binding_level->level_chain;
15380     }
15381   else
15382     {
15383       newlevel = make_binding_level ();
15384     }
15385
15386   /* Add this level to the front of the chain (stack) of levels that
15387      are active.  */
15388
15389   *newlevel = clear_binding_level;
15390   newlevel->level_chain = current_binding_level;
15391   current_binding_level = newlevel;
15392 }
15393
15394 /* Set the BLOCK node for the innermost scope
15395    (the one we are currently in).  */
15396
15397 void
15398 set_block (block)
15399      register tree block;
15400 {
15401   current_binding_level->this_block = block;
15402 }
15403
15404 /* ~~gcc/tree.h *should* declare this, because toplev.c references it.  */
15405
15406 /* Can't 'yydebug' a front end not generated by yacc/bison!  */
15407
15408 void
15409 set_yydebug (value)
15410      int value;
15411 {
15412   if (value)
15413     fprintf (stderr, "warning: no yacc/bison-generated output to debug!\n");
15414 }
15415
15416 tree
15417 signed_or_unsigned_type (unsignedp, type)
15418      int unsignedp;
15419      tree type;
15420 {
15421   tree type2;
15422
15423   if (! INTEGRAL_TYPE_P (type))
15424     return type;
15425   if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
15426     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15427   if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
15428     return unsignedp ? unsigned_type_node : integer_type_node;
15429   if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
15430     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15431   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
15432     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15433   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
15434     return (unsignedp ? long_long_unsigned_type_node
15435             : long_long_integer_type_node);
15436
15437   type2 = type_for_size (TYPE_PRECISION (type), unsignedp);
15438   if (type2 == NULL_TREE)
15439     return type;
15440
15441   return type2;
15442 }
15443
15444 tree
15445 signed_type (type)
15446      tree type;
15447 {
15448   tree type1 = TYPE_MAIN_VARIANT (type);
15449   ffeinfoKindtype kt;
15450   tree type2;
15451
15452   if (type1 == unsigned_char_type_node || type1 == char_type_node)
15453     return signed_char_type_node;
15454   if (type1 == unsigned_type_node)
15455     return integer_type_node;
15456   if (type1 == short_unsigned_type_node)
15457     return short_integer_type_node;
15458   if (type1 == long_unsigned_type_node)
15459     return long_integer_type_node;
15460   if (type1 == long_long_unsigned_type_node)
15461     return long_long_integer_type_node;
15462 #if 0   /* gcc/c-* files only */
15463   if (type1 == unsigned_intDI_type_node)
15464     return intDI_type_node;
15465   if (type1 == unsigned_intSI_type_node)
15466     return intSI_type_node;
15467   if (type1 == unsigned_intHI_type_node)
15468     return intHI_type_node;
15469   if (type1 == unsigned_intQI_type_node)
15470     return intQI_type_node;
15471 #endif
15472
15473   type2 = type_for_size (TYPE_PRECISION (type1), 0);
15474   if (type2 != NULL_TREE)
15475     return type2;
15476
15477   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15478     {
15479       type2 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15480
15481       if (type1 == type2)
15482         return ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15483     }
15484
15485   return type;
15486 }
15487
15488 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
15489    or validate its data type for an `if' or `while' statement or ?..: exp.
15490
15491    This preparation consists of taking the ordinary
15492    representation of an expression expr and producing a valid tree
15493    boolean expression describing whether expr is nonzero.  We could
15494    simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
15495    but we optimize comparisons, &&, ||, and !.
15496
15497    The resulting type should always be `integer_type_node'.  */
15498
15499 tree
15500 truthvalue_conversion (expr)
15501      tree expr;
15502 {
15503   if (TREE_CODE (expr) == ERROR_MARK)
15504     return expr;
15505
15506 #if 0 /* This appears to be wrong for C++.  */
15507   /* These really should return error_mark_node after 2.4 is stable.
15508      But not all callers handle ERROR_MARK properly.  */
15509   switch (TREE_CODE (TREE_TYPE (expr)))
15510     {
15511     case RECORD_TYPE:
15512       error ("struct type value used where scalar is required");
15513       return integer_zero_node;
15514
15515     case UNION_TYPE:
15516       error ("union type value used where scalar is required");
15517       return integer_zero_node;
15518
15519     case ARRAY_TYPE:
15520       error ("array type value used where scalar is required");
15521       return integer_zero_node;
15522
15523     default:
15524       break;
15525     }
15526 #endif /* 0 */
15527
15528   switch (TREE_CODE (expr))
15529     {
15530       /* It is simpler and generates better code to have only TRUTH_*_EXPR
15531          or comparison expressions as truth values at this level.  */
15532 #if 0
15533     case COMPONENT_REF:
15534       /* A one-bit unsigned bit-field is already acceptable.  */
15535       if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr, 1)))
15536           && TREE_UNSIGNED (TREE_OPERAND (expr, 1)))
15537         return expr;
15538       break;
15539 #endif
15540
15541     case EQ_EXPR:
15542       /* It is simpler and generates better code to have only TRUTH_*_EXPR
15543          or comparison expressions as truth values at this level.  */
15544 #if 0
15545       if (integer_zerop (TREE_OPERAND (expr, 1)))
15546         return build_unary_op (TRUTH_NOT_EXPR, TREE_OPERAND (expr, 0), 0);
15547 #endif
15548     case NE_EXPR: case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR:
15549     case TRUTH_ANDIF_EXPR:
15550     case TRUTH_ORIF_EXPR:
15551     case TRUTH_AND_EXPR:
15552     case TRUTH_OR_EXPR:
15553     case TRUTH_XOR_EXPR:
15554       TREE_TYPE (expr) = integer_type_node;
15555       return expr;
15556
15557     case ERROR_MARK:
15558       return expr;
15559
15560     case INTEGER_CST:
15561       return integer_zerop (expr) ? integer_zero_node : integer_one_node;
15562
15563     case REAL_CST:
15564       return real_zerop (expr) ? integer_zero_node : integer_one_node;
15565
15566     case ADDR_EXPR:
15567       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 0)))
15568         return build (COMPOUND_EXPR, integer_type_node,
15569                       TREE_OPERAND (expr, 0), integer_one_node);
15570       else
15571         return integer_one_node;
15572
15573     case COMPLEX_EXPR:
15574       return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1))
15575                         ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
15576                        integer_type_node,
15577                        truthvalue_conversion (TREE_OPERAND (expr, 0)),
15578                        truthvalue_conversion (TREE_OPERAND (expr, 1)));
15579
15580     case NEGATE_EXPR:
15581     case ABS_EXPR:
15582     case FLOAT_EXPR:
15583     case FFS_EXPR:
15584       /* These don't change whether an object is non-zero or zero.  */
15585       return truthvalue_conversion (TREE_OPERAND (expr, 0));
15586
15587     case LROTATE_EXPR:
15588     case RROTATE_EXPR:
15589       /* These don't change whether an object is zero or non-zero, but
15590          we can't ignore them if their second arg has side-effects.  */
15591       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)))
15592         return build (COMPOUND_EXPR, integer_type_node, TREE_OPERAND (expr, 1),
15593                       truthvalue_conversion (TREE_OPERAND (expr, 0)));
15594       else
15595         return truthvalue_conversion (TREE_OPERAND (expr, 0));
15596
15597     case COND_EXPR:
15598       /* Distribute the conversion into the arms of a COND_EXPR.  */
15599       return fold (build (COND_EXPR, integer_type_node, TREE_OPERAND (expr, 0),
15600                           truthvalue_conversion (TREE_OPERAND (expr, 1)),
15601                           truthvalue_conversion (TREE_OPERAND (expr, 2))));
15602
15603     case CONVERT_EXPR:
15604       /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
15605          since that affects how `default_conversion' will behave.  */
15606       if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE
15607           || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE)
15608         break;
15609       /* fall through... */
15610     case NOP_EXPR:
15611       /* If this is widening the argument, we can ignore it.  */
15612       if (TYPE_PRECISION (TREE_TYPE (expr))
15613           >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0))))
15614         return truthvalue_conversion (TREE_OPERAND (expr, 0));
15615       break;
15616
15617     case MINUS_EXPR:
15618       /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
15619          this case.  */
15620       if (TARGET_FLOAT_FORMAT == IEEE_FLOAT_FORMAT
15621           && TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE)
15622         break;
15623       /* fall through... */
15624     case BIT_XOR_EXPR:
15625       /* This and MINUS_EXPR can be changed into a comparison of the
15626          two objects.  */
15627       if (TREE_TYPE (TREE_OPERAND (expr, 0))
15628           == TREE_TYPE (TREE_OPERAND (expr, 1)))
15629         return ffecom_2 (NE_EXPR, integer_type_node,
15630                          TREE_OPERAND (expr, 0),
15631                          TREE_OPERAND (expr, 1));
15632       return ffecom_2 (NE_EXPR, integer_type_node,
15633                        TREE_OPERAND (expr, 0),
15634                        fold (build1 (NOP_EXPR,
15635                                      TREE_TYPE (TREE_OPERAND (expr, 0)),
15636                                      TREE_OPERAND (expr, 1))));
15637
15638     case BIT_AND_EXPR:
15639       if (integer_onep (TREE_OPERAND (expr, 1)))
15640         return expr;
15641       break;
15642
15643     case MODIFY_EXPR:
15644 #if 0                           /* No such thing in Fortran. */
15645       if (warn_parentheses && C_EXP_ORIGINAL_CODE (expr) == MODIFY_EXPR)
15646         warning ("suggest parentheses around assignment used as truth value");
15647 #endif
15648       break;
15649
15650     default:
15651       break;
15652     }
15653
15654   if (TREE_CODE (TREE_TYPE (expr)) == COMPLEX_TYPE)
15655     return (ffecom_2
15656             ((TREE_SIDE_EFFECTS (expr)
15657               ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
15658              integer_type_node,
15659              truthvalue_conversion (ffecom_1 (REALPART_EXPR,
15660                                               TREE_TYPE (TREE_TYPE (expr)),
15661                                               expr)),
15662              truthvalue_conversion (ffecom_1 (IMAGPART_EXPR,
15663                                               TREE_TYPE (TREE_TYPE (expr)),
15664                                               expr))));
15665
15666   return ffecom_2 (NE_EXPR, integer_type_node,
15667                    expr,
15668                    convert (TREE_TYPE (expr), integer_zero_node));
15669 }
15670
15671 tree
15672 type_for_mode (mode, unsignedp)
15673      enum machine_mode mode;
15674      int unsignedp;
15675 {
15676   int i;
15677   int j;
15678   tree t;
15679
15680   if (mode == TYPE_MODE (integer_type_node))
15681     return unsignedp ? unsigned_type_node : integer_type_node;
15682
15683   if (mode == TYPE_MODE (signed_char_type_node))
15684     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15685
15686   if (mode == TYPE_MODE (short_integer_type_node))
15687     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15688
15689   if (mode == TYPE_MODE (long_integer_type_node))
15690     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15691
15692   if (mode == TYPE_MODE (long_long_integer_type_node))
15693     return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node;
15694
15695 #if HOST_BITS_PER_WIDE_INT >= 64
15696   if (mode == TYPE_MODE (intTI_type_node))
15697     return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
15698 #endif
15699
15700   if (mode == TYPE_MODE (float_type_node))
15701     return float_type_node;
15702
15703   if (mode == TYPE_MODE (double_type_node))
15704     return double_type_node;
15705
15706   if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
15707     return build_pointer_type (char_type_node);
15708
15709   if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
15710     return build_pointer_type (integer_type_node);
15711
15712   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
15713     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
15714       {
15715         if (((t = ffecom_tree_type[i][j]) != NULL_TREE)
15716             && (mode == TYPE_MODE (t)))
15717           {
15718             if ((i == FFEINFO_basictypeINTEGER) && unsignedp)
15719               return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][j];
15720             else
15721               return t;
15722           }
15723       }
15724
15725   return 0;
15726 }
15727
15728 tree
15729 type_for_size (bits, unsignedp)
15730      unsigned bits;
15731      int unsignedp;
15732 {
15733   ffeinfoKindtype kt;
15734   tree type_node;
15735
15736   if (bits == TYPE_PRECISION (integer_type_node))
15737     return unsignedp ? unsigned_type_node : integer_type_node;
15738
15739   if (bits == TYPE_PRECISION (signed_char_type_node))
15740     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15741
15742   if (bits == TYPE_PRECISION (short_integer_type_node))
15743     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15744
15745   if (bits == TYPE_PRECISION (long_integer_type_node))
15746     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15747
15748   if (bits == TYPE_PRECISION (long_long_integer_type_node))
15749     return (unsignedp ? long_long_unsigned_type_node
15750             : long_long_integer_type_node);
15751
15752   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15753     {
15754       type_node = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15755
15756       if ((type_node != NULL_TREE) && (bits == TYPE_PRECISION (type_node)))
15757         return unsignedp ? ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]
15758           : type_node;
15759     }
15760
15761   return 0;
15762 }
15763
15764 tree
15765 unsigned_type (type)
15766      tree type;
15767 {
15768   tree type1 = TYPE_MAIN_VARIANT (type);
15769   ffeinfoKindtype kt;
15770   tree type2;
15771
15772   if (type1 == signed_char_type_node || type1 == char_type_node)
15773     return unsigned_char_type_node;
15774   if (type1 == integer_type_node)
15775     return unsigned_type_node;
15776   if (type1 == short_integer_type_node)
15777     return short_unsigned_type_node;
15778   if (type1 == long_integer_type_node)
15779     return long_unsigned_type_node;
15780   if (type1 == long_long_integer_type_node)
15781     return long_long_unsigned_type_node;
15782 #if 0   /* gcc/c-* files only */
15783   if (type1 == intDI_type_node)
15784     return unsigned_intDI_type_node;
15785   if (type1 == intSI_type_node)
15786     return unsigned_intSI_type_node;
15787   if (type1 == intHI_type_node)
15788     return unsigned_intHI_type_node;
15789   if (type1 == intQI_type_node)
15790     return unsigned_intQI_type_node;
15791 #endif
15792
15793   type2 = type_for_size (TYPE_PRECISION (type1), 1);
15794   if (type2 != NULL_TREE)
15795     return type2;
15796
15797   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15798     {
15799       type2 = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15800
15801       if (type1 == type2)
15802         return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15803     }
15804
15805   return type;
15806 }
15807
15808 /* Callback routines for garbage collection.  */
15809
15810 int ggc_p = 1;
15811
15812 void
15813 lang_mark_tree (t)
15814      union tree_node *t ATTRIBUTE_UNUSED;
15815 {
15816   if (TREE_CODE (t) == IDENTIFIER_NODE)
15817     {
15818       struct lang_identifier *i = (struct lang_identifier *) t;
15819       ggc_mark_tree (IDENTIFIER_GLOBAL_VALUE (i));
15820       ggc_mark_tree (IDENTIFIER_LOCAL_VALUE (i));
15821       ggc_mark_tree (IDENTIFIER_LABEL_VALUE (i));
15822     }
15823   else if (TYPE_P (t) && TYPE_LANG_SPECIFIC (t))
15824     ggc_mark (TYPE_LANG_SPECIFIC (t));
15825 }
15826
15827 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
15828 \f
15829 #if FFECOM_GCC_INCLUDE
15830
15831 /* From gcc/cccp.c, the code to handle -I.  */
15832
15833 /* Skip leading "./" from a directory name.
15834    This may yield the empty string, which represents the current directory.  */
15835
15836 static const char *
15837 skip_redundant_dir_prefix (const char *dir)
15838 {
15839   while (dir[0] == '.' && dir[1] == '/')
15840     for (dir += 2; *dir == '/'; dir++)
15841       continue;
15842   if (dir[0] == '.' && !dir[1])
15843     dir++;
15844   return dir;
15845 }
15846
15847 /* The file_name_map structure holds a mapping of file names for a
15848    particular directory.  This mapping is read from the file named
15849    FILE_NAME_MAP_FILE in that directory.  Such a file can be used to
15850    map filenames on a file system with severe filename restrictions,
15851    such as DOS.  The format of the file name map file is just a series
15852    of lines with two tokens on each line.  The first token is the name
15853    to map, and the second token is the actual name to use.  */
15854
15855 struct file_name_map
15856 {
15857   struct file_name_map *map_next;
15858   char *map_from;
15859   char *map_to;
15860 };
15861
15862 #define FILE_NAME_MAP_FILE "header.gcc"
15863
15864 /* Current maximum length of directory names in the search path
15865    for include files.  (Altered as we get more of them.)  */
15866
15867 static int max_include_len = 0;
15868
15869 struct file_name_list
15870   {
15871     struct file_name_list *next;
15872     char *fname;
15873     /* Mapping of file names for this directory.  */
15874     struct file_name_map *name_map;
15875     /* Non-zero if name_map is valid.  */
15876     int got_name_map;
15877   };
15878
15879 static struct file_name_list *include = NULL;   /* First dir to search */
15880 static struct file_name_list *last_include = NULL;      /* Last in chain */
15881
15882 /* I/O buffer structure.
15883    The `fname' field is nonzero for source files and #include files
15884    and for the dummy text used for -D and -U.
15885    It is zero for rescanning results of macro expansion
15886    and for expanding macro arguments.  */
15887 #define INPUT_STACK_MAX 400
15888 static struct file_buf {
15889   const char *fname;
15890   /* Filename specified with #line command.  */
15891   const char *nominal_fname;
15892   /* Record where in the search path this file was found.
15893      For #include_next.  */
15894   struct file_name_list *dir;
15895   ffewhereLine line;
15896   ffewhereColumn column;
15897 } instack[INPUT_STACK_MAX];
15898
15899 static int last_error_tick = 0;    /* Incremented each time we print it.  */
15900 static int input_file_stack_tick = 0;  /* Incremented when status changes.  */
15901
15902 /* Current nesting level of input sources.
15903    `instack[indepth]' is the level currently being read.  */
15904 static int indepth = -1;
15905
15906 typedef struct file_buf FILE_BUF;
15907
15908 typedef unsigned char U_CHAR;
15909
15910 /* table to tell if char can be part of a C identifier. */
15911 U_CHAR is_idchar[256];
15912 /* table to tell if char can be first char of a c identifier. */
15913 U_CHAR is_idstart[256];
15914 /* table to tell if c is horizontal space.  */
15915 U_CHAR is_hor_space[256];
15916 /* table to tell if c is horizontal or vertical space.  */
15917 static U_CHAR is_space[256];
15918
15919 #define SKIP_WHITE_SPACE(p) do { while (is_hor_space[*p]) p++; } while (0)
15920 #define SKIP_ALL_WHITE_SPACE(p) do { while (is_space[*p]) p++; } while (0)
15921
15922 /* Nonzero means -I- has been seen,
15923    so don't look for #include "foo" the source-file directory.  */
15924 static int ignore_srcdir;
15925
15926 #ifndef INCLUDE_LEN_FUDGE
15927 #define INCLUDE_LEN_FUDGE 0
15928 #endif
15929
15930 static void append_include_chain (struct file_name_list *first,
15931                                   struct file_name_list *last);
15932 static FILE *open_include_file (char *filename,
15933                                 struct file_name_list *searchptr);
15934 static void print_containing_files (ffebadSeverity sev);
15935 static const char *skip_redundant_dir_prefix (const char *);
15936 static char *read_filename_string (int ch, FILE *f);
15937 static struct file_name_map *read_name_map (const char *dirname);
15938
15939 /* Append a chain of `struct file_name_list's
15940    to the end of the main include chain.
15941    FIRST is the beginning of the chain to append, and LAST is the end.  */
15942
15943 static void
15944 append_include_chain (first, last)
15945      struct file_name_list *first, *last;
15946 {
15947   struct file_name_list *dir;
15948
15949   if (!first || !last)
15950     return;
15951
15952   if (include == 0)
15953     include = first;
15954   else
15955     last_include->next = first;
15956
15957   for (dir = first; ; dir = dir->next) {
15958     int len = strlen (dir->fname) + INCLUDE_LEN_FUDGE;
15959     if (len > max_include_len)
15960       max_include_len = len;
15961     if (dir == last)
15962       break;
15963   }
15964
15965   last->next = NULL;
15966   last_include = last;
15967 }
15968
15969 /* Try to open include file FILENAME.  SEARCHPTR is the directory
15970    being tried from the include file search path.  This function maps
15971    filenames on file systems based on information read by
15972    read_name_map.  */
15973
15974 static FILE *
15975 open_include_file (filename, searchptr)
15976      char *filename;
15977      struct file_name_list *searchptr;
15978 {
15979   register struct file_name_map *map;
15980   register char *from;
15981   char *p, *dir;
15982
15983   if (searchptr && ! searchptr->got_name_map)
15984     {
15985       searchptr->name_map = read_name_map (searchptr->fname
15986                                            ? searchptr->fname : ".");
15987       searchptr->got_name_map = 1;
15988     }
15989
15990   /* First check the mapping for the directory we are using.  */
15991   if (searchptr && searchptr->name_map)
15992     {
15993       from = filename;
15994       if (searchptr->fname)
15995         from += strlen (searchptr->fname) + 1;
15996       for (map = searchptr->name_map; map; map = map->map_next)
15997         {
15998           if (! strcmp (map->map_from, from))
15999             {
16000               /* Found a match.  */
16001               return fopen (map->map_to, "r");
16002             }
16003         }
16004     }
16005
16006   /* Try to find a mapping file for the particular directory we are
16007      looking in.  Thus #include <sys/types.h> will look up sys/types.h
16008      in /usr/include/header.gcc and look up types.h in
16009      /usr/include/sys/header.gcc.  */
16010   p = rindex (filename, '/');
16011 #ifdef DIR_SEPARATOR
16012   if (! p) p = rindex (filename, DIR_SEPARATOR);
16013   else {
16014     char *tmp = rindex (filename, DIR_SEPARATOR);
16015     if (tmp != NULL && tmp > p) p = tmp;
16016   }
16017 #endif
16018   if (! p)
16019     p = filename;
16020   if (searchptr
16021       && searchptr->fname
16022       && strlen (searchptr->fname) == (size_t) (p - filename)
16023       && ! strncmp (searchptr->fname, filename, (int) (p - filename)))
16024     {
16025       /* FILENAME is in SEARCHPTR, which we've already checked.  */
16026       return fopen (filename, "r");
16027     }
16028
16029   if (p == filename)
16030     {
16031       from = filename;
16032       map = read_name_map (".");
16033     }
16034   else
16035     {
16036       dir = (char *) xmalloc (p - filename + 1);
16037       memcpy (dir, filename, p - filename);
16038       dir[p - filename] = '\0';
16039       from = p + 1;
16040       map = read_name_map (dir);
16041       free (dir);
16042     }
16043   for (; map; map = map->map_next)
16044     if (! strcmp (map->map_from, from))
16045       return fopen (map->map_to, "r");
16046
16047   return fopen (filename, "r");
16048 }
16049
16050 /* Print the file names and line numbers of the #include
16051    commands which led to the current file.  */
16052
16053 static void
16054 print_containing_files (ffebadSeverity sev)
16055 {
16056   FILE_BUF *ip = NULL;
16057   int i;
16058   int first = 1;
16059   const char *str1;
16060   const char *str2;
16061
16062   /* If stack of files hasn't changed since we last printed
16063      this info, don't repeat it.  */
16064   if (last_error_tick == input_file_stack_tick)
16065     return;
16066
16067   for (i = indepth; i >= 0; i--)
16068     if (instack[i].fname != NULL) {
16069       ip = &instack[i];
16070       break;
16071     }
16072
16073   /* Give up if we don't find a source file.  */
16074   if (ip == NULL)
16075     return;
16076
16077   /* Find the other, outer source files.  */
16078   for (i--; i >= 0; i--)
16079     if (instack[i].fname != NULL)
16080       {
16081         ip = &instack[i];
16082         if (first)
16083           {
16084             first = 0;
16085             str1 = "In file included";
16086           }
16087         else
16088           {
16089             str1 = "...          ...";
16090           }
16091
16092         if (i == 1)
16093           str2 = ":";
16094         else
16095           str2 = "";
16096
16097         ffebad_start_msg ("%A from %B at %0%C", sev);
16098         ffebad_here (0, ip->line, ip->column);
16099         ffebad_string (str1);
16100         ffebad_string (ip->nominal_fname);
16101         ffebad_string (str2);
16102         ffebad_finish ();
16103       }
16104
16105   /* Record we have printed the status as of this time.  */
16106   last_error_tick = input_file_stack_tick;
16107 }
16108
16109 /* Read a space delimited string of unlimited length from a stdio
16110    file.  */
16111
16112 static char *
16113 read_filename_string (ch, f)
16114      int ch;
16115      FILE *f;
16116 {
16117   char *alloc, *set;
16118   int len;
16119
16120   len = 20;
16121   set = alloc = xmalloc (len + 1);
16122   if (! is_space[ch])
16123     {
16124       *set++ = ch;
16125       while ((ch = getc (f)) != EOF && ! is_space[ch])
16126         {
16127           if (set - alloc == len)
16128             {
16129               len *= 2;
16130               alloc = xrealloc (alloc, len + 1);
16131               set = alloc + len / 2;
16132             }
16133           *set++ = ch;
16134         }
16135     }
16136   *set = '\0';
16137   ungetc (ch, f);
16138   return alloc;
16139 }
16140
16141 /* Read the file name map file for DIRNAME.  */
16142
16143 static struct file_name_map *
16144 read_name_map (dirname)
16145      const char *dirname;
16146 {
16147   /* This structure holds a linked list of file name maps, one per
16148      directory.  */
16149   struct file_name_map_list
16150     {
16151       struct file_name_map_list *map_list_next;
16152       char *map_list_name;
16153       struct file_name_map *map_list_map;
16154     };
16155   static struct file_name_map_list *map_list;
16156   register struct file_name_map_list *map_list_ptr;
16157   char *name;
16158   FILE *f;
16159   size_t dirlen;
16160   int separator_needed;
16161
16162   dirname = skip_redundant_dir_prefix (dirname);
16163
16164   for (map_list_ptr = map_list; map_list_ptr;
16165        map_list_ptr = map_list_ptr->map_list_next)
16166     if (! strcmp (map_list_ptr->map_list_name, dirname))
16167       return map_list_ptr->map_list_map;
16168
16169   map_list_ptr = ((struct file_name_map_list *)
16170                   xmalloc (sizeof (struct file_name_map_list)));
16171   map_list_ptr->map_list_name = xstrdup (dirname);
16172   map_list_ptr->map_list_map = NULL;
16173
16174   dirlen = strlen (dirname);
16175   separator_needed = dirlen != 0 && dirname[dirlen - 1] != '/';
16176   name = (char *) xmalloc (dirlen + strlen (FILE_NAME_MAP_FILE) + 2);
16177   strcpy (name, dirname);
16178   name[dirlen] = '/';
16179   strcpy (name + dirlen + separator_needed, FILE_NAME_MAP_FILE);
16180   f = fopen (name, "r");
16181   free (name);
16182   if (!f)
16183     map_list_ptr->map_list_map = NULL;
16184   else
16185     {
16186       int ch;
16187
16188       while ((ch = getc (f)) != EOF)
16189         {
16190           char *from, *to;
16191           struct file_name_map *ptr;
16192
16193           if (is_space[ch])
16194             continue;
16195           from = read_filename_string (ch, f);
16196           while ((ch = getc (f)) != EOF && is_hor_space[ch])
16197             ;
16198           to = read_filename_string (ch, f);
16199
16200           ptr = ((struct file_name_map *)
16201                  xmalloc (sizeof (struct file_name_map)));
16202           ptr->map_from = from;
16203
16204           /* Make the real filename absolute.  */
16205           if (*to == '/')
16206             ptr->map_to = to;
16207           else
16208             {
16209               ptr->map_to = xmalloc (dirlen + strlen (to) + 2);
16210               strcpy (ptr->map_to, dirname);
16211               ptr->map_to[dirlen] = '/';
16212               strcpy (ptr->map_to + dirlen + separator_needed, to);
16213               free (to);
16214             }
16215
16216           ptr->map_next = map_list_ptr->map_list_map;
16217           map_list_ptr->map_list_map = ptr;
16218
16219           while ((ch = getc (f)) != '\n')
16220             if (ch == EOF)
16221               break;
16222         }
16223       fclose (f);
16224     }
16225
16226   map_list_ptr->map_list_next = map_list;
16227   map_list = map_list_ptr;
16228
16229   return map_list_ptr->map_list_map;
16230 }
16231
16232 static void
16233 ffecom_file_ (const char *name)
16234 {
16235   FILE_BUF *fp;
16236
16237   /* Do partial setup of input buffer for the sake of generating
16238      early #line directives (when -g is in effect).  */
16239
16240   fp = &instack[++indepth];
16241   memset ((char *) fp, 0, sizeof (FILE_BUF));
16242   if (name == NULL)
16243     name = "";
16244   fp->nominal_fname = fp->fname = name;
16245 }
16246
16247 /* Initialize syntactic classifications of characters.  */
16248
16249 static void
16250 ffecom_initialize_char_syntax_ ()
16251 {
16252   register int i;
16253
16254   /*
16255    * Set up is_idchar and is_idstart tables.  These should be
16256    * faster than saying (is_alpha (c) || c == '_'), etc.
16257    * Set up these things before calling any routines tthat
16258    * refer to them.
16259    */
16260   for (i = 'a'; i <= 'z'; i++) {
16261     is_idchar[i - 'a' + 'A'] = 1;
16262     is_idchar[i] = 1;
16263     is_idstart[i - 'a' + 'A'] = 1;
16264     is_idstart[i] = 1;
16265   }
16266   for (i = '0'; i <= '9'; i++)
16267     is_idchar[i] = 1;
16268   is_idchar['_'] = 1;
16269   is_idstart['_'] = 1;
16270
16271   /* horizontal space table */
16272   is_hor_space[' '] = 1;
16273   is_hor_space['\t'] = 1;
16274   is_hor_space['\v'] = 1;
16275   is_hor_space['\f'] = 1;
16276   is_hor_space['\r'] = 1;
16277
16278   is_space[' '] = 1;
16279   is_space['\t'] = 1;
16280   is_space['\v'] = 1;
16281   is_space['\f'] = 1;
16282   is_space['\n'] = 1;
16283   is_space['\r'] = 1;
16284 }
16285
16286 static void
16287 ffecom_close_include_ (FILE *f)
16288 {
16289   fclose (f);
16290
16291   indepth--;
16292   input_file_stack_tick++;
16293
16294   ffewhere_line_kill (instack[indepth].line);
16295   ffewhere_column_kill (instack[indepth].column);
16296 }
16297
16298 static int
16299 ffecom_decode_include_option_ (char *spec)
16300 {
16301   struct file_name_list *dirtmp;
16302
16303   if (! ignore_srcdir && !strcmp (spec, "-"))
16304     ignore_srcdir = 1;
16305   else
16306     {
16307       dirtmp = (struct file_name_list *)
16308         xmalloc (sizeof (struct file_name_list));
16309       dirtmp->next = 0;         /* New one goes on the end */
16310       if (spec[0] != 0)
16311         dirtmp->fname = spec;
16312       else
16313         fatal ("Directory name must immediately follow -I option with no intervening spaces, as in `-Idir', not `-I dir'");
16314       dirtmp->got_name_map = 0;
16315       append_include_chain (dirtmp, dirtmp);
16316     }
16317   return 1;
16318 }
16319
16320 /* Open INCLUDEd file.  */
16321
16322 static FILE *
16323 ffecom_open_include_ (char *name, ffewhereLine l, ffewhereColumn c)
16324 {
16325   char *fbeg = name;
16326   size_t flen = strlen (fbeg);
16327   struct file_name_list *search_start = include; /* Chain of dirs to search */
16328   struct file_name_list dsp[1]; /* First in chain, if #include "..." */
16329   struct file_name_list *searchptr = 0;
16330   char *fname;          /* Dynamically allocated fname buffer */
16331   FILE *f;
16332   FILE_BUF *fp;
16333
16334   if (flen == 0)
16335     return NULL;
16336
16337   dsp[0].fname = NULL;
16338
16339   /* If -I- was specified, don't search current dir, only spec'd ones. */
16340   if (!ignore_srcdir)
16341     {
16342       for (fp = &instack[indepth]; fp >= instack; fp--)
16343         {
16344           int n;
16345           char *ep;
16346           const char *nam;
16347
16348           if ((nam = fp->nominal_fname) != NULL)
16349             {
16350               /* Found a named file.  Figure out dir of the file,
16351                  and put it in front of the search list.  */
16352               dsp[0].next = search_start;
16353               search_start = dsp;
16354 #ifndef VMS
16355               ep = rindex (nam, '/');
16356 #ifdef DIR_SEPARATOR
16357             if (ep == NULL) ep = rindex (nam, DIR_SEPARATOR);
16358             else {
16359               char *tmp = rindex (nam, DIR_SEPARATOR);
16360               if (tmp != NULL && tmp > ep) ep = tmp;
16361             }
16362 #endif
16363 #else                           /* VMS */
16364               ep = rindex (nam, ']');
16365               if (ep == NULL) ep = rindex (nam, '>');
16366               if (ep == NULL) ep = rindex (nam, ':');
16367               if (ep != NULL) ep++;
16368 #endif                          /* VMS */
16369               if (ep != NULL)
16370                 {
16371                   n = ep - nam;
16372                   dsp[0].fname = (char *) xmalloc (n + 1);
16373                   strncpy (dsp[0].fname, nam, n);
16374                   dsp[0].fname[n] = '\0';
16375                   if (n + INCLUDE_LEN_FUDGE > max_include_len)
16376                     max_include_len = n + INCLUDE_LEN_FUDGE;
16377                 }
16378               else
16379                 dsp[0].fname = NULL; /* Current directory */
16380               dsp[0].got_name_map = 0;
16381               break;
16382             }
16383         }
16384     }
16385
16386   /* Allocate this permanently, because it gets stored in the definitions
16387      of macros.  */
16388   fname = xmalloc (max_include_len + flen + 4);
16389   /* + 2 above for slash and terminating null.  */
16390   /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
16391      for g77 yet).  */
16392
16393   /* If specified file name is absolute, just open it.  */
16394
16395   if (*fbeg == '/'
16396 #ifdef DIR_SEPARATOR
16397       || *fbeg == DIR_SEPARATOR
16398 #endif
16399       )
16400     {
16401       strncpy (fname, (char *) fbeg, flen);
16402       fname[flen] = 0;
16403       f = open_include_file (fname, NULL_PTR);
16404     }
16405   else
16406     {
16407       f = NULL;
16408
16409       /* Search directory path, trying to open the file.
16410          Copy each filename tried into FNAME.  */
16411
16412       for (searchptr = search_start; searchptr; searchptr = searchptr->next)
16413         {
16414           if (searchptr->fname)
16415             {
16416               /* The empty string in a search path is ignored.
16417                  This makes it possible to turn off entirely
16418                  a standard piece of the list.  */
16419               if (searchptr->fname[0] == 0)
16420                 continue;
16421               strcpy (fname, skip_redundant_dir_prefix (searchptr->fname));
16422               if (fname[0] && fname[strlen (fname) - 1] != '/')
16423                 strcat (fname, "/");
16424               fname[strlen (fname) + flen] = 0;
16425             }
16426           else
16427             fname[0] = 0;
16428
16429           strncat (fname, fbeg, flen);
16430 #ifdef VMS
16431           /* Change this 1/2 Unix 1/2 VMS file specification into a
16432              full VMS file specification */
16433           if (searchptr->fname && (searchptr->fname[0] != 0))
16434             {
16435               /* Fix up the filename */
16436               hack_vms_include_specification (fname);
16437             }
16438           else
16439             {
16440               /* This is a normal VMS filespec, so use it unchanged.  */
16441               strncpy (fname, (char *) fbeg, flen);
16442               fname[flen] = 0;
16443 #if 0   /* Not for g77.  */
16444               /* if it's '#include filename', add the missing .h */
16445               if (index (fname, '.') == NULL)
16446                 strcat (fname, ".h");
16447 #endif
16448             }
16449 #endif /* VMS */
16450           f = open_include_file (fname, searchptr);
16451 #ifdef EACCES
16452           if (f == NULL && errno == EACCES)
16453             {
16454               print_containing_files (FFEBAD_severityWARNING);
16455               ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
16456                                 FFEBAD_severityWARNING);
16457               ffebad_string (fname);
16458               ffebad_here (0, l, c);
16459               ffebad_finish ();
16460             }
16461 #endif
16462           if (f != NULL)
16463             break;
16464         }
16465     }
16466
16467   if (f == NULL)
16468     {
16469       /* A file that was not found.  */
16470
16471       strncpy (fname, (char *) fbeg, flen);
16472       fname[flen] = 0;
16473       print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE));
16474       ffebad_start (FFEBAD_OPEN_INCLUDE);
16475       ffebad_here (0, l, c);
16476       ffebad_string (fname);
16477       ffebad_finish ();
16478     }
16479
16480   if (dsp[0].fname != NULL)
16481     free (dsp[0].fname);
16482
16483   if (f == NULL)
16484     return NULL;
16485
16486   if (indepth >= (INPUT_STACK_MAX - 1))
16487     {
16488       print_containing_files (FFEBAD_severityFATAL);
16489       ffebad_start_msg ("At %0, INCLUDE nesting too deep",
16490                         FFEBAD_severityFATAL);
16491       ffebad_string (fname);
16492       ffebad_here (0, l, c);
16493       ffebad_finish ();
16494       return NULL;
16495     }
16496
16497   instack[indepth].line = ffewhere_line_use (l);
16498   instack[indepth].column = ffewhere_column_use (c);
16499
16500   fp = &instack[indepth + 1];
16501   memset ((char *) fp, 0, sizeof (FILE_BUF));
16502   fp->nominal_fname = fp->fname = fname;
16503   fp->dir = searchptr;
16504
16505   indepth++;
16506   input_file_stack_tick++;
16507
16508   return f;
16509 }
16510 #endif  /* FFECOM_GCC_INCLUDE */
16511
16512 /**INDENT* (Do not reformat this comment even with -fca option.)
16513    Data-gathering files: Given the source file listed below, compiled with
16514    f2c I obtained the output file listed after that, and from the output
16515    file I derived the above code.
16516
16517 -------- (begin input file to f2c)
16518         implicit none
16519         character*10 A1,A2
16520         complex C1,C2
16521         integer I1,I2
16522         real R1,R2
16523         double precision D1,D2
16524 C
16525         call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
16526 c /
16527         call fooI(I1/I2)
16528         call fooR(R1/I1)
16529         call fooD(D1/I1)
16530         call fooC(C1/I1)
16531         call fooR(R1/R2)
16532         call fooD(R1/D1)
16533         call fooD(D1/D2)
16534         call fooD(D1/R1)
16535         call fooC(C1/C2)
16536         call fooC(C1/R1)
16537         call fooZ(C1/D1)
16538 c **
16539         call fooI(I1**I2)
16540         call fooR(R1**I1)
16541         call fooD(D1**I1)
16542         call fooC(C1**I1)
16543         call fooR(R1**R2)
16544         call fooD(R1**D1)
16545         call fooD(D1**D2)
16546         call fooD(D1**R1)
16547         call fooC(C1**C2)
16548         call fooC(C1**R1)
16549         call fooZ(C1**D1)
16550 c FFEINTRIN_impABS
16551         call fooR(ABS(R1))
16552 c FFEINTRIN_impACOS
16553         call fooR(ACOS(R1))
16554 c FFEINTRIN_impAIMAG
16555         call fooR(AIMAG(C1))
16556 c FFEINTRIN_impAINT
16557         call fooR(AINT(R1))
16558 c FFEINTRIN_impALOG
16559         call fooR(ALOG(R1))
16560 c FFEINTRIN_impALOG10
16561         call fooR(ALOG10(R1))
16562 c FFEINTRIN_impAMAX0
16563         call fooR(AMAX0(I1,I2))
16564 c FFEINTRIN_impAMAX1
16565         call fooR(AMAX1(R1,R2))
16566 c FFEINTRIN_impAMIN0
16567         call fooR(AMIN0(I1,I2))
16568 c FFEINTRIN_impAMIN1
16569         call fooR(AMIN1(R1,R2))
16570 c FFEINTRIN_impAMOD
16571         call fooR(AMOD(R1,R2))
16572 c FFEINTRIN_impANINT
16573         call fooR(ANINT(R1))
16574 c FFEINTRIN_impASIN
16575         call fooR(ASIN(R1))
16576 c FFEINTRIN_impATAN
16577         call fooR(ATAN(R1))
16578 c FFEINTRIN_impATAN2
16579         call fooR(ATAN2(R1,R2))
16580 c FFEINTRIN_impCABS
16581         call fooR(CABS(C1))
16582 c FFEINTRIN_impCCOS
16583         call fooC(CCOS(C1))
16584 c FFEINTRIN_impCEXP
16585         call fooC(CEXP(C1))
16586 c FFEINTRIN_impCHAR
16587         call fooA(CHAR(I1))
16588 c FFEINTRIN_impCLOG
16589         call fooC(CLOG(C1))
16590 c FFEINTRIN_impCONJG
16591         call fooC(CONJG(C1))
16592 c FFEINTRIN_impCOS
16593         call fooR(COS(R1))
16594 c FFEINTRIN_impCOSH
16595         call fooR(COSH(R1))
16596 c FFEINTRIN_impCSIN
16597         call fooC(CSIN(C1))
16598 c FFEINTRIN_impCSQRT
16599         call fooC(CSQRT(C1))
16600 c FFEINTRIN_impDABS
16601         call fooD(DABS(D1))
16602 c FFEINTRIN_impDACOS
16603         call fooD(DACOS(D1))
16604 c FFEINTRIN_impDASIN
16605         call fooD(DASIN(D1))
16606 c FFEINTRIN_impDATAN
16607         call fooD(DATAN(D1))
16608 c FFEINTRIN_impDATAN2
16609         call fooD(DATAN2(D1,D2))
16610 c FFEINTRIN_impDCOS
16611         call fooD(DCOS(D1))
16612 c FFEINTRIN_impDCOSH
16613         call fooD(DCOSH(D1))
16614 c FFEINTRIN_impDDIM
16615         call fooD(DDIM(D1,D2))
16616 c FFEINTRIN_impDEXP
16617         call fooD(DEXP(D1))
16618 c FFEINTRIN_impDIM
16619         call fooR(DIM(R1,R2))
16620 c FFEINTRIN_impDINT
16621         call fooD(DINT(D1))
16622 c FFEINTRIN_impDLOG
16623         call fooD(DLOG(D1))
16624 c FFEINTRIN_impDLOG10
16625         call fooD(DLOG10(D1))
16626 c FFEINTRIN_impDMAX1
16627         call fooD(DMAX1(D1,D2))
16628 c FFEINTRIN_impDMIN1
16629         call fooD(DMIN1(D1,D2))
16630 c FFEINTRIN_impDMOD
16631         call fooD(DMOD(D1,D2))
16632 c FFEINTRIN_impDNINT
16633         call fooD(DNINT(D1))
16634 c FFEINTRIN_impDPROD
16635         call fooD(DPROD(R1,R2))
16636 c FFEINTRIN_impDSIGN
16637         call fooD(DSIGN(D1,D2))
16638 c FFEINTRIN_impDSIN
16639         call fooD(DSIN(D1))
16640 c FFEINTRIN_impDSINH
16641         call fooD(DSINH(D1))
16642 c FFEINTRIN_impDSQRT
16643         call fooD(DSQRT(D1))
16644 c FFEINTRIN_impDTAN
16645         call fooD(DTAN(D1))
16646 c FFEINTRIN_impDTANH
16647         call fooD(DTANH(D1))
16648 c FFEINTRIN_impEXP
16649         call fooR(EXP(R1))
16650 c FFEINTRIN_impIABS
16651         call fooI(IABS(I1))
16652 c FFEINTRIN_impICHAR
16653         call fooI(ICHAR(A1))
16654 c FFEINTRIN_impIDIM
16655         call fooI(IDIM(I1,I2))
16656 c FFEINTRIN_impIDNINT
16657         call fooI(IDNINT(D1))
16658 c FFEINTRIN_impINDEX
16659         call fooI(INDEX(A1,A2))
16660 c FFEINTRIN_impISIGN
16661         call fooI(ISIGN(I1,I2))
16662 c FFEINTRIN_impLEN
16663         call fooI(LEN(A1))
16664 c FFEINTRIN_impLGE
16665         call fooL(LGE(A1,A2))
16666 c FFEINTRIN_impLGT
16667         call fooL(LGT(A1,A2))
16668 c FFEINTRIN_impLLE
16669         call fooL(LLE(A1,A2))
16670 c FFEINTRIN_impLLT
16671         call fooL(LLT(A1,A2))
16672 c FFEINTRIN_impMAX0
16673         call fooI(MAX0(I1,I2))
16674 c FFEINTRIN_impMAX1
16675         call fooI(MAX1(R1,R2))
16676 c FFEINTRIN_impMIN0
16677         call fooI(MIN0(I1,I2))
16678 c FFEINTRIN_impMIN1
16679         call fooI(MIN1(R1,R2))
16680 c FFEINTRIN_impMOD
16681         call fooI(MOD(I1,I2))
16682 c FFEINTRIN_impNINT
16683         call fooI(NINT(R1))
16684 c FFEINTRIN_impSIGN
16685         call fooR(SIGN(R1,R2))
16686 c FFEINTRIN_impSIN
16687         call fooR(SIN(R1))
16688 c FFEINTRIN_impSINH
16689         call fooR(SINH(R1))
16690 c FFEINTRIN_impSQRT
16691         call fooR(SQRT(R1))
16692 c FFEINTRIN_impTAN
16693         call fooR(TAN(R1))
16694 c FFEINTRIN_impTANH
16695         call fooR(TANH(R1))
16696 c FFEINTRIN_imp_CMPLX_C
16697         call fooC(cmplx(C1,C2))
16698 c FFEINTRIN_imp_CMPLX_D
16699         call fooZ(cmplx(D1,D2))
16700 c FFEINTRIN_imp_CMPLX_I
16701         call fooC(cmplx(I1,I2))
16702 c FFEINTRIN_imp_CMPLX_R
16703         call fooC(cmplx(R1,R2))
16704 c FFEINTRIN_imp_DBLE_C
16705         call fooD(dble(C1))
16706 c FFEINTRIN_imp_DBLE_D
16707         call fooD(dble(D1))
16708 c FFEINTRIN_imp_DBLE_I
16709         call fooD(dble(I1))
16710 c FFEINTRIN_imp_DBLE_R
16711         call fooD(dble(R1))
16712 c FFEINTRIN_imp_INT_C
16713         call fooI(int(C1))
16714 c FFEINTRIN_imp_INT_D
16715         call fooI(int(D1))
16716 c FFEINTRIN_imp_INT_I
16717         call fooI(int(I1))
16718 c FFEINTRIN_imp_INT_R
16719         call fooI(int(R1))
16720 c FFEINTRIN_imp_REAL_C
16721         call fooR(real(C1))
16722 c FFEINTRIN_imp_REAL_D
16723         call fooR(real(D1))
16724 c FFEINTRIN_imp_REAL_I
16725         call fooR(real(I1))
16726 c FFEINTRIN_imp_REAL_R
16727         call fooR(real(R1))
16728 c
16729 c FFEINTRIN_imp_INT_D:
16730 c
16731 c FFEINTRIN_specIDINT
16732         call fooI(IDINT(D1))
16733 c
16734 c FFEINTRIN_imp_INT_R:
16735 c
16736 c FFEINTRIN_specIFIX
16737         call fooI(IFIX(R1))
16738 c FFEINTRIN_specINT
16739         call fooI(INT(R1))
16740 c
16741 c FFEINTRIN_imp_REAL_D:
16742 c
16743 c FFEINTRIN_specSNGL
16744         call fooR(SNGL(D1))
16745 c
16746 c FFEINTRIN_imp_REAL_I:
16747 c
16748 c FFEINTRIN_specFLOAT
16749         call fooR(FLOAT(I1))
16750 c FFEINTRIN_specREAL
16751         call fooR(REAL(I1))
16752 c
16753         end
16754 -------- (end input file to f2c)
16755
16756 -------- (begin output from providing above input file as input to:
16757 --------  `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
16758 --------     -e "s:^#.*$::g"')
16759
16760 //  -- translated by f2c (version 19950223).
16761    You must link the resulting object file with the libraries:
16762         -lf2c -lm   (in that order)
16763 //
16764
16765
16766 // f2c.h  --  Standard Fortran to C header file //
16767
16768 ///  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
16769
16770         - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
16771
16772
16773
16774
16775 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
16776 // we assume short, float are OK //
16777 typedef long int // long int // integer;
16778 typedef char *address;
16779 typedef short int shortint;
16780 typedef float real;
16781 typedef double doublereal;
16782 typedef struct { real r, i; } complex;
16783 typedef struct { doublereal r, i; } doublecomplex;
16784 typedef long int // long int // logical;
16785 typedef short int shortlogical;
16786 typedef char logical1;
16787 typedef char integer1;
16788 // typedef long long longint; // // system-dependent //
16789
16790
16791
16792
16793 // Extern is for use with -E //
16794
16795
16796
16797
16798 // I/O stuff //
16799
16800
16801
16802
16803
16804
16805
16806
16807 typedef long int // int or long int // flag;
16808 typedef long int // int or long int // ftnlen;
16809 typedef long int // int or long int // ftnint;
16810
16811
16812 //external read, write//
16813 typedef struct
16814 {       flag cierr;
16815         ftnint ciunit;
16816         flag ciend;
16817         char *cifmt;
16818         ftnint cirec;
16819 } cilist;
16820
16821 //internal read, write//
16822 typedef struct
16823 {       flag icierr;
16824         char *iciunit;
16825         flag iciend;
16826         char *icifmt;
16827         ftnint icirlen;
16828         ftnint icirnum;
16829 } icilist;
16830
16831 //open//
16832 typedef struct
16833 {       flag oerr;
16834         ftnint ounit;
16835         char *ofnm;
16836         ftnlen ofnmlen;
16837         char *osta;
16838         char *oacc;
16839         char *ofm;
16840         ftnint orl;
16841         char *oblnk;
16842 } olist;
16843
16844 //close//
16845 typedef struct
16846 {       flag cerr;
16847         ftnint cunit;
16848         char *csta;
16849 } cllist;
16850
16851 //rewind, backspace, endfile//
16852 typedef struct
16853 {       flag aerr;
16854         ftnint aunit;
16855 } alist;
16856
16857 // inquire //
16858 typedef struct
16859 {       flag inerr;
16860         ftnint inunit;
16861         char *infile;
16862         ftnlen infilen;
16863         ftnint  *inex;  //parameters in standard's order//
16864         ftnint  *inopen;
16865         ftnint  *innum;
16866         ftnint  *innamed;
16867         char    *inname;
16868         ftnlen  innamlen;
16869         char    *inacc;
16870         ftnlen  inacclen;
16871         char    *inseq;
16872         ftnlen  inseqlen;
16873         char    *indir;
16874         ftnlen  indirlen;
16875         char    *infmt;
16876         ftnlen  infmtlen;
16877         char    *inform;
16878         ftnint  informlen;
16879         char    *inunf;
16880         ftnlen  inunflen;
16881         ftnint  *inrecl;
16882         ftnint  *innrec;
16883         char    *inblank;
16884         ftnlen  inblanklen;
16885 } inlist;
16886
16887
16888
16889 union Multitype {       // for multiple entry points //
16890         integer1 g;
16891         shortint h;
16892         integer i;
16893         // longint j; //
16894         real r;
16895         doublereal d;
16896         complex c;
16897         doublecomplex z;
16898         };
16899
16900 typedef union Multitype Multitype;
16901
16902 typedef long Long;      // No longer used; formerly in Namelist //
16903
16904 struct Vardesc {        // for Namelist //
16905         char *name;
16906         char *addr;
16907         ftnlen *dims;
16908         int  type;
16909         };
16910 typedef struct Vardesc Vardesc;
16911
16912 struct Namelist {
16913         char *name;
16914         Vardesc **vars;
16915         int nvars;
16916         };
16917 typedef struct Namelist Namelist;
16918
16919
16920
16921
16922
16923
16924
16925
16926 // procedure parameter types for -A and -C++ //
16927
16928
16929
16930
16931 typedef int // Unknown procedure type // (*U_fp)();
16932 typedef shortint (*J_fp)();
16933 typedef integer (*I_fp)();
16934 typedef real (*R_fp)();
16935 typedef doublereal (*D_fp)(), (*E_fp)();
16936 typedef // Complex // void  (*C_fp)();
16937 typedef // Double Complex // void  (*Z_fp)();
16938 typedef logical (*L_fp)();
16939 typedef shortlogical (*K_fp)();
16940 typedef // Character // void  (*H_fp)();
16941 typedef // Subroutine // int (*S_fp)();
16942
16943 // E_fp is for real functions when -R is not specified //
16944 typedef void  C_f;      // complex function //
16945 typedef void  H_f;      // character function //
16946 typedef void  Z_f;      // double complex function //
16947 typedef doublereal E_f; // real function with -R not specified //
16948
16949 // undef any lower-case symbols that your C compiler predefines, e.g.: //
16950
16951
16952 // (No such symbols should be defined in a strict ANSI C compiler.
16953    We can avoid trouble with f2c-translated code by using
16954    gcc -ansi [-traditional].) //
16955
16956
16957
16958
16959
16960
16961
16962
16963
16964
16965
16966
16967
16968
16969
16970
16971
16972
16973
16974
16975
16976
16977
16978 // Main program // MAIN__()
16979 {
16980     // System generated locals //
16981     integer i__1;
16982     real r__1, r__2;
16983     doublereal d__1, d__2;
16984     complex q__1;
16985     doublecomplex z__1, z__2, z__3;
16986     logical L__1;
16987     char ch__1[1];
16988
16989     // Builtin functions //
16990     void c_div();
16991     integer pow_ii();
16992     double pow_ri(), pow_di();
16993     void pow_ci();
16994     double pow_dd();
16995     void pow_zz();
16996     double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
16997             asin(), atan(), atan2(), c_abs();
16998     void c_cos(), c_exp(), c_log(), r_cnjg();
16999     double cos(), cosh();
17000     void c_sin(), c_sqrt();
17001     double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
17002             d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
17003     integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
17004     logical l_ge(), l_gt(), l_le(), l_lt();
17005     integer i_nint();
17006     double r_sign();
17007
17008     // Local variables //
17009     extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
17010             fool_(), fooz_(), getem_();
17011     static char a1[10], a2[10];
17012     static complex c1, c2;
17013     static doublereal d1, d2;
17014     static integer i1, i2;
17015     static real r1, r2;
17016
17017
17018     getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
17019 // / //
17020     i__1 = i1 / i2;
17021     fooi_(&i__1);
17022     r__1 = r1 / i1;
17023     foor_(&r__1);
17024     d__1 = d1 / i1;
17025     food_(&d__1);
17026     d__1 = (doublereal) i1;
17027     q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
17028     fooc_(&q__1);
17029     r__1 = r1 / r2;
17030     foor_(&r__1);
17031     d__1 = r1 / d1;
17032     food_(&d__1);
17033     d__1 = d1 / d2;
17034     food_(&d__1);
17035     d__1 = d1 / r1;
17036     food_(&d__1);
17037     c_div(&q__1, &c1, &c2);
17038     fooc_(&q__1);
17039     q__1.r = c1.r / r1, q__1.i = c1.i / r1;
17040     fooc_(&q__1);
17041     z__1.r = c1.r / d1, z__1.i = c1.i / d1;
17042     fooz_(&z__1);
17043 // ** //
17044     i__1 = pow_ii(&i1, &i2);
17045     fooi_(&i__1);
17046     r__1 = pow_ri(&r1, &i1);
17047     foor_(&r__1);
17048     d__1 = pow_di(&d1, &i1);
17049     food_(&d__1);
17050     pow_ci(&q__1, &c1, &i1);
17051     fooc_(&q__1);
17052     d__1 = (doublereal) r1;
17053     d__2 = (doublereal) r2;
17054     r__1 = pow_dd(&d__1, &d__2);
17055     foor_(&r__1);
17056     d__2 = (doublereal) r1;
17057     d__1 = pow_dd(&d__2, &d1);
17058     food_(&d__1);
17059     d__1 = pow_dd(&d1, &d2);
17060     food_(&d__1);
17061     d__2 = (doublereal) r1;
17062     d__1 = pow_dd(&d1, &d__2);
17063     food_(&d__1);
17064     z__2.r = c1.r, z__2.i = c1.i;
17065     z__3.r = c2.r, z__3.i = c2.i;
17066     pow_zz(&z__1, &z__2, &z__3);
17067     q__1.r = z__1.r, q__1.i = z__1.i;
17068     fooc_(&q__1);
17069     z__2.r = c1.r, z__2.i = c1.i;
17070     z__3.r = r1, z__3.i = 0.;
17071     pow_zz(&z__1, &z__2, &z__3);
17072     q__1.r = z__1.r, q__1.i = z__1.i;
17073     fooc_(&q__1);
17074     z__2.r = c1.r, z__2.i = c1.i;
17075     z__3.r = d1, z__3.i = 0.;
17076     pow_zz(&z__1, &z__2, &z__3);
17077     fooz_(&z__1);
17078 // FFEINTRIN_impABS //
17079     r__1 = (doublereal)((  r1  ) >= 0 ? (  r1  ) : -(  r1  ))  ;
17080     foor_(&r__1);
17081 // FFEINTRIN_impACOS //
17082     r__1 = acos(r1);
17083     foor_(&r__1);
17084 // FFEINTRIN_impAIMAG //
17085     r__1 = r_imag(&c1);
17086     foor_(&r__1);
17087 // FFEINTRIN_impAINT //
17088     r__1 = r_int(&r1);
17089     foor_(&r__1);
17090 // FFEINTRIN_impALOG //
17091     r__1 = log(r1);
17092     foor_(&r__1);
17093 // FFEINTRIN_impALOG10 //
17094     r__1 = r_lg10(&r1);
17095     foor_(&r__1);
17096 // FFEINTRIN_impAMAX0 //
17097     r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
17098     foor_(&r__1);
17099 // FFEINTRIN_impAMAX1 //
17100     r__1 = (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
17101     foor_(&r__1);
17102 // FFEINTRIN_impAMIN0 //
17103     r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
17104     foor_(&r__1);
17105 // FFEINTRIN_impAMIN1 //
17106     r__1 = (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
17107     foor_(&r__1);
17108 // FFEINTRIN_impAMOD //
17109     r__1 = r_mod(&r1, &r2);
17110     foor_(&r__1);
17111 // FFEINTRIN_impANINT //
17112     r__1 = r_nint(&r1);
17113     foor_(&r__1);
17114 // FFEINTRIN_impASIN //
17115     r__1 = asin(r1);
17116     foor_(&r__1);
17117 // FFEINTRIN_impATAN //
17118     r__1 = atan(r1);
17119     foor_(&r__1);
17120 // FFEINTRIN_impATAN2 //
17121     r__1 = atan2(r1, r2);
17122     foor_(&r__1);
17123 // FFEINTRIN_impCABS //
17124     r__1 = c_abs(&c1);
17125     foor_(&r__1);
17126 // FFEINTRIN_impCCOS //
17127     c_cos(&q__1, &c1);
17128     fooc_(&q__1);
17129 // FFEINTRIN_impCEXP //
17130     c_exp(&q__1, &c1);
17131     fooc_(&q__1);
17132 // FFEINTRIN_impCHAR //
17133     *(unsigned char *)&ch__1[0] = i1;
17134     fooa_(ch__1, 1L);
17135 // FFEINTRIN_impCLOG //
17136     c_log(&q__1, &c1);
17137     fooc_(&q__1);
17138 // FFEINTRIN_impCONJG //
17139     r_cnjg(&q__1, &c1);
17140     fooc_(&q__1);
17141 // FFEINTRIN_impCOS //
17142     r__1 = cos(r1);
17143     foor_(&r__1);
17144 // FFEINTRIN_impCOSH //
17145     r__1 = cosh(r1);
17146     foor_(&r__1);
17147 // FFEINTRIN_impCSIN //
17148     c_sin(&q__1, &c1);
17149     fooc_(&q__1);
17150 // FFEINTRIN_impCSQRT //
17151     c_sqrt(&q__1, &c1);
17152     fooc_(&q__1);
17153 // FFEINTRIN_impDABS //
17154     d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
17155     food_(&d__1);
17156 // FFEINTRIN_impDACOS //
17157     d__1 = acos(d1);
17158     food_(&d__1);
17159 // FFEINTRIN_impDASIN //
17160     d__1 = asin(d1);
17161     food_(&d__1);
17162 // FFEINTRIN_impDATAN //
17163     d__1 = atan(d1);
17164     food_(&d__1);
17165 // FFEINTRIN_impDATAN2 //
17166     d__1 = atan2(d1, d2);
17167     food_(&d__1);
17168 // FFEINTRIN_impDCOS //
17169     d__1 = cos(d1);
17170     food_(&d__1);
17171 // FFEINTRIN_impDCOSH //
17172     d__1 = cosh(d1);
17173     food_(&d__1);
17174 // FFEINTRIN_impDDIM //
17175     d__1 = d_dim(&d1, &d2);
17176     food_(&d__1);
17177 // FFEINTRIN_impDEXP //
17178     d__1 = exp(d1);
17179     food_(&d__1);
17180 // FFEINTRIN_impDIM //
17181     r__1 = r_dim(&r1, &r2);
17182     foor_(&r__1);
17183 // FFEINTRIN_impDINT //
17184     d__1 = d_int(&d1);
17185     food_(&d__1);
17186 // FFEINTRIN_impDLOG //
17187     d__1 = log(d1);
17188     food_(&d__1);
17189 // FFEINTRIN_impDLOG10 //
17190     d__1 = d_lg10(&d1);
17191     food_(&d__1);
17192 // FFEINTRIN_impDMAX1 //
17193     d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
17194     food_(&d__1);
17195 // FFEINTRIN_impDMIN1 //
17196     d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
17197     food_(&d__1);
17198 // FFEINTRIN_impDMOD //
17199     d__1 = d_mod(&d1, &d2);
17200     food_(&d__1);
17201 // FFEINTRIN_impDNINT //
17202     d__1 = d_nint(&d1);
17203     food_(&d__1);
17204 // FFEINTRIN_impDPROD //
17205     d__1 = (doublereal) r1 * r2;
17206     food_(&d__1);
17207 // FFEINTRIN_impDSIGN //
17208     d__1 = d_sign(&d1, &d2);
17209     food_(&d__1);
17210 // FFEINTRIN_impDSIN //
17211     d__1 = sin(d1);
17212     food_(&d__1);
17213 // FFEINTRIN_impDSINH //
17214     d__1 = sinh(d1);
17215     food_(&d__1);
17216 // FFEINTRIN_impDSQRT //
17217     d__1 = sqrt(d1);
17218     food_(&d__1);
17219 // FFEINTRIN_impDTAN //
17220     d__1 = tan(d1);
17221     food_(&d__1);
17222 // FFEINTRIN_impDTANH //
17223     d__1 = tanh(d1);
17224     food_(&d__1);
17225 // FFEINTRIN_impEXP //
17226     r__1 = exp(r1);
17227     foor_(&r__1);
17228 // FFEINTRIN_impIABS //
17229     i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
17230     fooi_(&i__1);
17231 // FFEINTRIN_impICHAR //
17232     i__1 = *(unsigned char *)a1;
17233     fooi_(&i__1);
17234 // FFEINTRIN_impIDIM //
17235     i__1 = i_dim(&i1, &i2);
17236     fooi_(&i__1);
17237 // FFEINTRIN_impIDNINT //
17238     i__1 = i_dnnt(&d1);
17239     fooi_(&i__1);
17240 // FFEINTRIN_impINDEX //
17241     i__1 = i_indx(a1, a2, 10L, 10L);
17242     fooi_(&i__1);
17243 // FFEINTRIN_impISIGN //
17244     i__1 = i_sign(&i1, &i2);
17245     fooi_(&i__1);
17246 // FFEINTRIN_impLEN //
17247     i__1 = i_len(a1, 10L);
17248     fooi_(&i__1);
17249 // FFEINTRIN_impLGE //
17250     L__1 = l_ge(a1, a2, 10L, 10L);
17251     fool_(&L__1);
17252 // FFEINTRIN_impLGT //
17253     L__1 = l_gt(a1, a2, 10L, 10L);
17254     fool_(&L__1);
17255 // FFEINTRIN_impLLE //
17256     L__1 = l_le(a1, a2, 10L, 10L);
17257     fool_(&L__1);
17258 // FFEINTRIN_impLLT //
17259     L__1 = l_lt(a1, a2, 10L, 10L);
17260     fool_(&L__1);
17261 // FFEINTRIN_impMAX0 //
17262     i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
17263     fooi_(&i__1);
17264 // FFEINTRIN_impMAX1 //
17265     i__1 = (integer) (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
17266     fooi_(&i__1);
17267 // FFEINTRIN_impMIN0 //
17268     i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
17269     fooi_(&i__1);
17270 // FFEINTRIN_impMIN1 //
17271     i__1 = (integer) (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
17272     fooi_(&i__1);
17273 // FFEINTRIN_impMOD //
17274     i__1 = i1 % i2;
17275     fooi_(&i__1);
17276 // FFEINTRIN_impNINT //
17277     i__1 = i_nint(&r1);
17278     fooi_(&i__1);
17279 // FFEINTRIN_impSIGN //
17280     r__1 = r_sign(&r1, &r2);
17281     foor_(&r__1);
17282 // FFEINTRIN_impSIN //
17283     r__1 = sin(r1);
17284     foor_(&r__1);
17285 // FFEINTRIN_impSINH //
17286     r__1 = sinh(r1);
17287     foor_(&r__1);
17288 // FFEINTRIN_impSQRT //
17289     r__1 = sqrt(r1);
17290     foor_(&r__1);
17291 // FFEINTRIN_impTAN //
17292     r__1 = tan(r1);
17293     foor_(&r__1);
17294 // FFEINTRIN_impTANH //
17295     r__1 = tanh(r1);
17296     foor_(&r__1);
17297 // FFEINTRIN_imp_CMPLX_C //
17298     r__1 = c1.r;
17299     r__2 = c2.r;
17300     q__1.r = r__1, q__1.i = r__2;
17301     fooc_(&q__1);
17302 // FFEINTRIN_imp_CMPLX_D //
17303     z__1.r = d1, z__1.i = d2;
17304     fooz_(&z__1);
17305 // FFEINTRIN_imp_CMPLX_I //
17306     r__1 = (real) i1;
17307     r__2 = (real) i2;
17308     q__1.r = r__1, q__1.i = r__2;
17309     fooc_(&q__1);
17310 // FFEINTRIN_imp_CMPLX_R //
17311     q__1.r = r1, q__1.i = r2;
17312     fooc_(&q__1);
17313 // FFEINTRIN_imp_DBLE_C //
17314     d__1 = (doublereal) c1.r;
17315     food_(&d__1);
17316 // FFEINTRIN_imp_DBLE_D //
17317     d__1 = d1;
17318     food_(&d__1);
17319 // FFEINTRIN_imp_DBLE_I //
17320     d__1 = (doublereal) i1;
17321     food_(&d__1);
17322 // FFEINTRIN_imp_DBLE_R //
17323     d__1 = (doublereal) r1;
17324     food_(&d__1);
17325 // FFEINTRIN_imp_INT_C //
17326     i__1 = (integer) c1.r;
17327     fooi_(&i__1);
17328 // FFEINTRIN_imp_INT_D //
17329     i__1 = (integer) d1;
17330     fooi_(&i__1);
17331 // FFEINTRIN_imp_INT_I //
17332     i__1 = i1;
17333     fooi_(&i__1);
17334 // FFEINTRIN_imp_INT_R //
17335     i__1 = (integer) r1;
17336     fooi_(&i__1);
17337 // FFEINTRIN_imp_REAL_C //
17338     r__1 = c1.r;
17339     foor_(&r__1);
17340 // FFEINTRIN_imp_REAL_D //
17341     r__1 = (real) d1;
17342     foor_(&r__1);
17343 // FFEINTRIN_imp_REAL_I //
17344     r__1 = (real) i1;
17345     foor_(&r__1);
17346 // FFEINTRIN_imp_REAL_R //
17347     r__1 = r1;
17348     foor_(&r__1);
17349
17350 // FFEINTRIN_imp_INT_D: //
17351
17352 // FFEINTRIN_specIDINT //
17353     i__1 = (integer) d1;
17354     fooi_(&i__1);
17355
17356 // FFEINTRIN_imp_INT_R: //
17357
17358 // FFEINTRIN_specIFIX //
17359     i__1 = (integer) r1;
17360     fooi_(&i__1);
17361 // FFEINTRIN_specINT //
17362     i__1 = (integer) r1;
17363     fooi_(&i__1);
17364
17365 // FFEINTRIN_imp_REAL_D: //
17366
17367 // FFEINTRIN_specSNGL //
17368     r__1 = (real) d1;
17369     foor_(&r__1);
17370
17371 // FFEINTRIN_imp_REAL_I: //
17372
17373 // FFEINTRIN_specFLOAT //
17374     r__1 = (real) i1;
17375     foor_(&r__1);
17376 // FFEINTRIN_specREAL //
17377     r__1 = (real) i1;
17378     foor_(&r__1);
17379
17380 } // MAIN__ //
17381
17382 -------- (end output file from f2c)
17383
17384 */