gcc/f/com.c

   1 /* com.c -- Implementation File (module.c template V1.0)
   2    Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000
   3    Free Software Foundation, Inc.
   4    Contributed by James Craig Burley.
   5
   6 This file is part of GNU Fortran.
   7
   8 GNU Fortran is free software; you can redistribute it and/or modify
   9 it under the terms of the GNU General Public License as published by
  10 the Free Software Foundation; either version 2, or (at your option)
  11 any later version.
  12
  13 GNU Fortran is distributed in the hope that it will be useful,
  14 but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 GNU General Public License for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GNU Fortran; see the file COPYING.  If not, write to
  20 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
  21 02111-1307, USA.
  22
  23    Related Modules:
  24       None
  25
  26    Description:
  27       Contains compiler-specific functions.
  28
  29    Modifications:
  30 */
  31
  32 /* Understanding this module means understanding the interface between
  33    the g77 front end and the gcc back end (or, perhaps, some other
  34    back end).  In here are the functions called by the front end proper
  35    to notify whatever back end is in place about certain things, and
  36    also the back-end-specific functions.  It's a bear to deal with, so
  37    lately I've been trying to simplify things, especially with regard
  38    to the gcc-back-end-specific stuff.
  39
  40    Building expressions generally seems quite easy, but building decls
  41    has been challenging and is undergoing revision.  gcc has several
  42    kinds of decls:
  43
  44    TYPE_DECL -- a type (int, float, struct, function, etc.)
  45    CONST_DECL -- a constant of some type other than function
  46    LABEL_DECL -- a variable or a constant?
  47    PARM_DECL -- an argument to a function (a variable that is a dummy)
  48    RESULT_DECL -- the return value of a function (a variable)
  49    VAR_DECL -- other variable (can hold a ptr-to-function, struct, int, etc.)
  50    FUNCTION_DECL -- a function (either the actual function or an extern ref)
  51    FIELD_DECL -- a field in a struct or union (goes into types)
  52
  53    g77 has a set of functions that somewhat parallels the gcc front end
  54    when it comes to building decls:
  55
  56    Internal Function (one we define, not just declare as extern):
  57    int yes;
  58    yes = suspend_momentary ();
  59    if (is_nested) push_f_function_context ();
  60    start_function (get_identifier ("function_name"), function_type,
  61                    is_nested, is_public);
  62    // for each arg, build PARM_DECL and call push_parm_decl (decl) with it;
  63    store_parm_decls (is_main_program);
  64    ffecom_start_compstmt ();
  65    // for stmts and decls inside function, do appropriate things;
  66    ffecom_end_compstmt ();
  67    finish_function (is_nested);
  68    if (is_nested) pop_f_function_context ();
  69    if (is_nested) resume_momentary (yes);
  70
  71    Everything Else:
  72    int yes;
  73    tree d;
  74    tree init;
  75    yes = suspend_momentary ();
  76    // fill in external, public, static, &c for decl, and
  77    // set DECL_INITIAL to error_mark_node if going to initialize
  78    // set is_top_level TRUE only if not at top level and decl
  79    // must go in top level (i.e. not within current function decl context)
  80    d = start_decl (decl, is_top_level);
  81    init = ...;  // if have initializer
  82    finish_decl (d, init, is_top_level);
  83    resume_momentary (yes);
  84
  85 */
  86
  87 /* Include files. */
  88
  89 #include "proj.h"
  90 #if FFECOM_targetCURRENT == FFECOM_targetGCC
  91 #include "flags.j"
  92 #include "rtl.j"
  93 #include "toplev.j"
  94 #include "tree.j"
  95 #include "output.j"  /* Must follow tree.j so TREE_CODE is defined! */
  96 #include "convert.j"
  97 #include "ggc.j"
  98 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
  99
 100 #define FFECOM_GCC_INCLUDE 1    /* Enable -I. */
 101
 102 /* BEGIN stuff from gcc/cccp.c.  */
 103
 104 /* The following symbols should be autoconfigured:
 105         HAVE_FCNTL_H
 106         HAVE_STDLIB_H
 107         HAVE_SYS_TIME_H
 108         HAVE_UNISTD_H
 109         STDC_HEADERS
 110         TIME_WITH_SYS_TIME
 111    In the mean time, we'll get by with approximations based
 112    on existing GCC configuration symbols.  */
 113
 114 #ifdef POSIX
 115 # ifndef HAVE_STDLIB_H
 116 # define HAVE_STDLIB_H 1
 117 # endif
 118 # ifndef HAVE_UNISTD_H
 119 # define HAVE_UNISTD_H 1
 120 # endif
 121 # ifndef STDC_HEADERS
 122 # define STDC_HEADERS 1
 123 # endif
 124 #endif /* defined (POSIX) */
 125
 126 #if defined (POSIX) || (defined (USG) && !defined (VMS))
 127 # ifndef HAVE_FCNTL_H
 128 # define HAVE_FCNTL_H 1
 129 # endif
 130 #endif
 131
 132 #ifndef RLIMIT_STACK
 133 # include <time.h>
 134 #else
 135 # if TIME_WITH_SYS_TIME
 136 #  include <sys/time.h>
 137 #  include <time.h>
 138 # else
 139 #  if HAVE_SYS_TIME_H
 140 #   include <sys/time.h>
 141 #  else
 142 #   include <time.h>
 143 #  endif
 144 # endif
 145 # include <sys/resource.h>
 146 #endif
 147
 148 #if HAVE_FCNTL_H
 149 # include <fcntl.h>
 150 #endif
 151
 152 /* This defines "errno" properly for VMS, and gives us EACCES. */
 153 #include <errno.h>
 154
 155 #if HAVE_STDLIB_H
 156 # include <stdlib.h>
 157 #else
 158 char *getenv ();
 159 #endif
 160
 161 #if HAVE_UNISTD_H
 162 # include <unistd.h>
 163 #endif
 164
 165 /* VMS-specific definitions */
 166 #ifdef VMS
 167 #include <descrip.h>
 168 #define O_RDONLY        0       /* Open arg for Read/Only  */
 169 #define O_WRONLY        1       /* Open arg for Write/Only */
 170 #define read(fd,buf,size)       VMS_read (fd,buf,size)
 171 #define write(fd,buf,size)      VMS_write (fd,buf,size)
 172 #define open(fname,mode,prot)   VMS_open (fname,mode,prot)
 173 #define fopen(fname,mode)       VMS_fopen (fname,mode)
 174 #define freopen(fname,mode,ofile) VMS_freopen (fname,mode,ofile)
 175 #define strncat(dst,src,cnt) VMS_strncat (dst,src,cnt)
 176 #define fstat(fd,stbuf)         VMS_fstat (fd,stbuf)
 177 static int VMS_fstat (), VMS_stat ();
 178 static char * VMS_strncat ();
 179 static int VMS_read ();
 180 static int VMS_write ();
 181 static int VMS_open ();
 182 static FILE * VMS_fopen ();
 183 static FILE * VMS_freopen ();
 184 static void hack_vms_include_specification ();
 185 typedef struct { unsigned :16, :16, :16; } vms_ino_t;
 186 #define ino_t vms_ino_t
 187 #define INCLUDE_LEN_FUDGE 10    /* leave room for VMS syntax conversion */
 188 #ifdef __GNUC__
 189 #define BSTRING                 /* VMS/GCC supplies the bstring routines */
 190 #endif /* __GNUC__ */
 191 #endif /* VMS */
 192
 193 #ifndef O_RDONLY
 194 #define O_RDONLY 0
 195 #endif
 196
 197 /* END stuff from gcc/cccp.c.  */
 198
 199 #define FFECOM_DETERMINE_TYPES 1 /* for com.h */
 200 #include "com.h"
 201 #include "bad.h"
 202 #include "bld.h"
 203 #include "equiv.h"
 204 #include "expr.h"
 205 #include "implic.h"
 206 #include "info.h"
 207 #include "malloc.h"
 208 #include "src.h"
 209 #include "st.h"
 210 #include "storag.h"
 211 #include "symbol.h"
 212 #include "target.h"
 213 #include "top.h"
 214 #include "type.h"
 215
 216 /* Externals defined here.  */
 217
 218 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 219
 220 /* ~~gcc/tree.h *should* declare this, because toplev.c and dwarfout.c
 221    reference it.  */
 222
 223 const char * const language_string = "GNU F77";
 224
 225 /* Stream for reading from the input file.  */
 226 FILE *finput;
 227
 228 /* These definitions parallel those in c-decl.c so that code from that
 229    module can be used pretty much as is.  Much of these defs aren't
 230    otherwise used, i.e. by g77 code per se, except some of them are used
 231    to build some of them that are.  The ones that are global (i.e. not
 232    "static") are those that ste.c and such might use (directly
 233    or by using com macros that reference them in their definitions).  */
 234
 235 tree string_type_node;
 236
 237 /* The rest of these are inventions for g77, though there might be
 238    similar things in the C front end.  As they are found, these
 239    inventions should be renamed to be canonical.  Note that only
 240    the ones currently required to be global are so.  */
 241
 242 static tree ffecom_tree_fun_type_void;
 243
 244 tree ffecom_integer_type_node;  /* Abbrev for _tree_type[blah][blah]. */
 245 tree ffecom_integer_zero_node;  /* Like *_*_* with g77's integer type. */
 246 tree ffecom_integer_one_node;   /* " */
 247 tree ffecom_tree_type[FFEINFO_basictype][FFEINFO_kindtype];
 248
 249 /* _fun_type things are the f2c-specific versions.  For -fno-f2c,
 250    just use build_function_type and build_pointer_type on the
 251    appropriate _tree_type array element.  */
 252
 253 static tree ffecom_tree_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
 254 static tree ffecom_tree_ptr_to_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
 255 static tree ffecom_tree_subr_type;
 256 static tree ffecom_tree_ptr_to_subr_type;
 257 static tree ffecom_tree_blockdata_type;
 258
 259 static tree ffecom_tree_xargc_;
 260
 261 ffecomSymbol ffecom_symbol_null_
 262 =
 263 {
 264   NULL_TREE,
 265   NULL_TREE,
 266   NULL_TREE,
 267   NULL_TREE,
 268   false
 269 };
 270 ffeinfoKindtype ffecom_pointer_kind_ = FFEINFO_basictypeNONE;
 271 ffeinfoKindtype ffecom_label_kind_ = FFEINFO_basictypeNONE;
 272
 273 int ffecom_f2c_typecode_[FFEINFO_basictype][FFEINFO_kindtype];
 274 tree ffecom_f2c_integer_type_node;
 275 tree ffecom_f2c_ptr_to_integer_type_node;
 276 tree ffecom_f2c_address_type_node;
 277 tree ffecom_f2c_real_type_node;
 278 tree ffecom_f2c_ptr_to_real_type_node;
 279 tree ffecom_f2c_doublereal_type_node;
 280 tree ffecom_f2c_complex_type_node;
 281 tree ffecom_f2c_doublecomplex_type_node;
 282 tree ffecom_f2c_longint_type_node;
 283 tree ffecom_f2c_logical_type_node;
 284 tree ffecom_f2c_flag_type_node;
 285 tree ffecom_f2c_ftnlen_type_node;
 286 tree ffecom_f2c_ftnlen_zero_node;
 287 tree ffecom_f2c_ftnlen_one_node;
 288 tree ffecom_f2c_ftnlen_two_node;
 289 tree ffecom_f2c_ptr_to_ftnlen_type_node;
 290 tree ffecom_f2c_ftnint_type_node;
 291 tree ffecom_f2c_ptr_to_ftnint_type_node;
 292 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 293
 294 /* Simple definitions and enumerations. */
 295
 296 #ifndef FFECOM_sizeMAXSTACKITEM
 297 #define FFECOM_sizeMAXSTACKITEM 32*1024 /* Keep user-declared things
 298                                            larger than this # bytes
 299                                            off stack if possible. */
 300 #endif
 301
 302 /* For systems that have large enough stacks, they should define
 303    this to 0, and here, for ease of use later on, we just undefine
 304    it if it is 0.  */
 305
 306 #if FFECOM_sizeMAXSTACKITEM == 0
 307 #undef FFECOM_sizeMAXSTACKITEM
 308 #endif
 309
 310 typedef enum
 311   {
 312     FFECOM_rttypeVOID_,
 313     FFECOM_rttypeVOIDSTAR_,     /* C's `void *' type. */
 314     FFECOM_rttypeFTNINT_,       /* f2c's `ftnint' type. */
 315     FFECOM_rttypeINTEGER_,      /* f2c's `integer' type. */
 316     FFECOM_rttypeLONGINT_,      /* f2c's `longint' type. */
 317     FFECOM_rttypeLOGICAL_,      /* f2c's `logical' type. */
 318     FFECOM_rttypeREAL_F2C_,     /* f2c's `real' returned as `double'. */
 319     FFECOM_rttypeREAL_GNU_,     /* `real' returned as such. */
 320     FFECOM_rttypeCOMPLEX_F2C_,  /* f2c's `complex' returned via 1st arg. */
 321     FFECOM_rttypeCOMPLEX_GNU_,  /* f2c's `complex' returned directly. */
 322     FFECOM_rttypeDOUBLE_,       /* C's `double' type. */
 323     FFECOM_rttypeDOUBLEREAL_,   /* f2c's `doublereal' type. */
 324     FFECOM_rttypeDBLCMPLX_F2C_, /* f2c's `doublecomplex' returned via 1st arg. */
 325     FFECOM_rttypeDBLCMPLX_GNU_, /* f2c's `doublecomplex' returned directly. */
 326     FFECOM_rttypeCHARACTER_,    /* f2c `char *'/`ftnlen' pair. */
 327     FFECOM_rttype_
 328   } ffecomRttype_;
 329
 330 /* Internal typedefs. */
 331
 332 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 333 typedef struct _ffecom_concat_list_ ffecomConcatList_;
 334 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 335
 336 /* Private include files. */
 337
 338
 339 /* Internal structure definitions. */
 340
 341 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 342 struct _ffecom_concat_list_
 343   {
 344     ffebld *exprs;
 345     int count;
 346     int max;
 347     ffetargetCharacterSize minlen;
 348     ffetargetCharacterSize maxlen;
 349   };
 350 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 351
 352 /* Static functions (internal). */
 353
 354 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 355 static tree ffecom_arglist_expr_ (const char *argstring, ffebld args);
 356 static tree ffecom_widest_expr_type_ (ffebld list);
 357 static bool ffecom_overlap_ (tree dest_decl, tree dest_offset,
 358                              tree dest_size, tree source_tree,
 359                              ffebld source, bool scalar_arg);
 360 static bool ffecom_args_overlapping_ (tree dest_tree, ffebld dest,
 361                                       tree args, tree callee_commons,
 362                                       bool scalar_args);
 363 static tree ffecom_build_f2c_string_ (int i, const char *s);
 364 static tree ffecom_call_ (tree fn, ffeinfoKindtype kt,
 365                           bool is_f2c_complex, tree type,
 366                           tree args, tree dest_tree,
 367                           ffebld dest, bool *dest_used,
 368                           tree callee_commons, bool scalar_args, tree hook);
 369 static tree ffecom_call_binop_ (tree fn, ffeinfoKindtype kt,
 370                                 bool is_f2c_complex, tree type,
 371                                 ffebld left, ffebld right,
 372                                 tree dest_tree, ffebld dest,
 373                                 bool *dest_used, tree callee_commons,
 374                                 bool scalar_args, tree hook);
 375 static void ffecom_char_args_x_ (tree *xitem, tree *length,
 376                                  ffebld expr, bool with_null);
 377 static tree ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy);
 378 static tree ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s);
 379 static ffecomConcatList_
 380   ffecom_concat_list_gather_ (ffecomConcatList_ catlist,
 381                               ffebld expr,
 382                               ffetargetCharacterSize max);
 383 static void ffecom_concat_list_kill_ (ffecomConcatList_ catlist);
 384 static ffecomConcatList_ ffecom_concat_list_new_ (ffebld expr,
 385                                                 ffetargetCharacterSize max);
 386 static void ffecom_debug_kludge_ (tree aggr, const char *aggr_type,
 387                                   ffesymbol member, tree member_type,
 388                                   ffetargetOffset offset);
 389 static void ffecom_do_entry_ (ffesymbol fn, int entrynum);
 390 static tree ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
 391                           bool *dest_used, bool assignp, bool widenp);
 392 static tree ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
 393                                     ffebld dest, bool *dest_used);
 394 static tree ffecom_expr_power_integer_ (ffebld expr);
 395 static void ffecom_expr_transform_ (ffebld expr);
 396 static void ffecom_f2c_make_type_ (tree *type, int tcode, const char *name);
 397 static void ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
 398                                       int code);
 399 static ffeglobal ffecom_finish_global_ (ffeglobal global);
 400 static ffesymbol ffecom_finish_symbol_transform_ (ffesymbol s);
 401 static tree ffecom_get_appended_identifier_ (char us, const char *text);
 402 static tree ffecom_get_external_identifier_ (ffesymbol s);
 403 static tree ffecom_get_identifier_ (const char *text);
 404 static tree ffecom_gen_sfuncdef_ (ffesymbol s,
 405                                   ffeinfoBasictype bt,
 406                                   ffeinfoKindtype kt);
 407 static const char *ffecom_gfrt_args_ (ffecomGfrt ix);
 408 static tree ffecom_gfrt_tree_ (ffecomGfrt ix);
 409 static tree ffecom_init_zero_ (tree decl);
 410 static tree ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
 411                                      tree *maybe_tree);
 412 static tree ffecom_intrinsic_len_ (ffebld expr);
 413 static void ffecom_let_char_ (tree dest_tree,
 414                               tree dest_length,
 415                               ffetargetCharacterSize dest_size,
 416                               ffebld source);
 417 static void ffecom_make_gfrt_ (ffecomGfrt ix);
 418 static void ffecom_member_phase1_ (ffestorag mst, ffestorag st);
 419 static void ffecom_member_phase2_ (ffestorag mst, ffestorag st);
 420 static void ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size,
 421                                       ffebld source);
 422 static void ffecom_push_dummy_decls_ (ffebld dumlist,
 423                                       bool stmtfunc);
 424 static void ffecom_start_progunit_ (void);
 425 static ffesymbol ffecom_sym_transform_ (ffesymbol s);
 426 static ffesymbol ffecom_sym_transform_assign_ (ffesymbol s);
 427 static void ffecom_transform_common_ (ffesymbol s);
 428 static void ffecom_transform_equiv_ (ffestorag st);
 429 static tree ffecom_transform_namelist_ (ffesymbol s);
 430 static void ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
 431                                        tree t);
 432 static void ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
 433                                        tree *size, tree tree);
 434 static tree ffecom_tree_divide_ (tree tree_type, tree left, tree right,
 435                                  tree dest_tree, ffebld dest,
 436                                  bool *dest_used, tree hook);
 437 static tree ffecom_type_localvar_ (ffesymbol s,
 438                                    ffeinfoBasictype bt,
 439                                    ffeinfoKindtype kt);
 440 static tree ffecom_type_namelist_ (void);
 441 static tree ffecom_type_vardesc_ (void);
 442 static tree ffecom_vardesc_ (ffebld expr);
 443 static tree ffecom_vardesc_array_ (ffesymbol s);
 444 static tree ffecom_vardesc_dims_ (ffesymbol s);
 445 static tree ffecom_convert_narrow_ (tree type, tree expr);
 446 static tree ffecom_convert_widen_ (tree type, tree expr);
 447 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 448
 449 /* These are static functions that parallel those found in the C front
 450    end and thus have the same names.  */
 451
 452 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 453 static tree bison_rule_compstmt_ (void);
 454 static void bison_rule_pushlevel_ (void);
 455 static void delete_block (tree block);
 456 static int duplicate_decls (tree newdecl, tree olddecl);
 457 static void finish_decl (tree decl, tree init, bool is_top_level);
 458 static void finish_function (int nested);
 459 static const char *lang_printable_name (tree decl, int v);
 460 static tree lookup_name_current_level (tree name);
 461 static struct binding_level *make_binding_level (void);
 462 static void pop_f_function_context (void);
 463 static void push_f_function_context (void);
 464 static void push_parm_decl (tree parm);
 465 static tree pushdecl_top_level (tree decl);
 466 static int kept_level_p (void);
 467 static tree storedecls (tree decls);
 468 static void store_parm_decls (int is_main_program);
 469 static tree start_decl (tree decl, bool is_top_level);
 470 static void start_function (tree name, tree type, int nested, int public);
 471 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 472 #if FFECOM_GCC_INCLUDE
 473 static void ffecom_file_ (const char *name);
 474 static void ffecom_initialize_char_syntax_ (void);
 475 static void ffecom_close_include_ (FILE *f);
 476 static int ffecom_decode_include_option_ (char *spec);
 477 static FILE *ffecom_open_include_ (char *name, ffewhereLine l,
 478                                    ffewhereColumn c);
 479 #endif  /* FFECOM_GCC_INCLUDE */
 480
 481 /* Static objects accessed by functions in this module. */
 482
 483 static ffesymbol ffecom_primary_entry_ = NULL;
 484 static ffesymbol ffecom_nested_entry_ = NULL;
 485 static ffeinfoKind ffecom_primary_entry_kind_;
 486 static bool ffecom_primary_entry_is_proc_;
 487 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 488 static tree ffecom_outer_function_decl_;
 489 static tree ffecom_previous_function_decl_;
 490 static tree ffecom_which_entrypoint_decl_;
 491 static tree ffecom_float_zero_ = NULL_TREE;
 492 static tree ffecom_float_half_ = NULL_TREE;
 493 static tree ffecom_double_zero_ = NULL_TREE;
 494 static tree ffecom_double_half_ = NULL_TREE;
 495 static tree ffecom_func_result_;/* For functions. */
 496 static tree ffecom_func_length_;/* For CHARACTER fns. */
 497 static ffebld ffecom_list_blockdata_;
 498 static ffebld ffecom_list_common_;
 499 static ffebld ffecom_master_arglist_;
 500 static ffeinfoBasictype ffecom_master_bt_;
 501 static ffeinfoKindtype ffecom_master_kt_;
 502 static ffetargetCharacterSize ffecom_master_size_;
 503 static int ffecom_num_fns_ = 0;
 504 static int ffecom_num_entrypoints_ = 0;
 505 static bool ffecom_is_altreturning_ = FALSE;
 506 static tree ffecom_multi_type_node_;
 507 static tree ffecom_multi_retval_;
 508 static tree
 509   ffecom_multi_fields_[FFEINFO_basictype][FFEINFO_kindtype];
 510 static bool ffecom_member_namelisted_;  /* _member_phase1_ namelisted? */
 511 static bool ffecom_doing_entry_ = FALSE;
 512 static bool ffecom_transform_only_dummies_ = FALSE;
 513 static int ffecom_typesize_pointer_;
 514 static int ffecom_typesize_integer1_;
 515
 516 /* Holds pointer-to-function expressions.  */
 517
 518 static tree ffecom_gfrt_[FFECOM_gfrt]
 519 =
 520 {
 521 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) NULL_TREE,
 522 #include "com-rt.def"
 523 #undef DEFGFRT
 524 };
 525
 526 /* Holds the external names of the functions.  */
 527
 528 static const char *ffecom_gfrt_name_[FFECOM_gfrt]
 529 =
 530 {
 531 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) NAME,
 532 #include "com-rt.def"
 533 #undef DEFGFRT
 534 };
 535
 536 /* Whether the function returns.  */
 537
 538 static bool ffecom_gfrt_volatile_[FFECOM_gfrt]
 539 =
 540 {
 541 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) VOLATILE,
 542 #include "com-rt.def"
 543 #undef DEFGFRT
 544 };
 545
 546 /* Whether the function returns type complex.  */
 547
 548 static bool ffecom_gfrt_complex_[FFECOM_gfrt]
 549 =
 550 {
 551 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) COMPLEX,
 552 #include "com-rt.def"
 553 #undef DEFGFRT
 554 };
 555
 556 /* Type code for the function return value.  */
 557
 558 static ffecomRttype_ ffecom_gfrt_type_[FFECOM_gfrt]
 559 =
 560 {
 561 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) TYPE,
 562 #include "com-rt.def"
 563 #undef DEFGFRT
 564 };
 565
 566 /* String of codes for the function's arguments.  */
 567
 568 static const char *ffecom_gfrt_argstring_[FFECOM_gfrt]
 569 =
 570 {
 571 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX) ARGS,
 572 #include "com-rt.def"
 573 #undef DEFGFRT
 574 };
 575 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 576
 577 /* Internal macros. */
 578
 579 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 580
 581 /* We let tm.h override the types used here, to handle trivial differences
 582    such as the choice of unsigned int or long unsigned int for size_t.
 583    When machines start needing nontrivial differences in the size type,
 584    it would be best to do something here to figure out automatically
 585    from other information what type to use.  */
 586
 587 #ifndef SIZE_TYPE
 588 #define SIZE_TYPE "long unsigned int"
 589 #endif
 590
 591 #define ffecom_concat_list_count_(catlist) ((catlist).count)
 592 #define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)])
 593 #define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen)
 594 #define ffecom_concat_list_minlen_(catlist) ((catlist).minlen)
 595
 596 #define ffecom_char_args_(i,l,e) ffecom_char_args_x_((i),(l),(e),FALSE)
 597 #define ffecom_char_args_with_null_(i,l,e) ffecom_char_args_x_((i),(l),(e),TRUE)
 598
 599 /* For each binding contour we allocate a binding_level structure
 600  * which records the names defined in that contour.
 601  * Contours include:
 602  *  0) the global one
 603  *  1) one for each function definition,
 604  *     where internal declarations of the parameters appear.
 605  *
 606  * The current meaning of a name can be found by searching the levels from
 607  * the current one out to the global one.
 608  */
 609
 610 /* Note that the information in the `names' component of the global contour
 611    is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers.  */
 612
 613 struct binding_level
 614   {
 615     /* A chain of _DECL nodes for all variables, constants, functions,
 616        and typedef types.  These are in the reverse of the order supplied.
 617      */
 618     tree names;
 619
 620     /* For each level (except not the global one),
 621        a chain of BLOCK nodes for all the levels
 622        that were entered and exited one level down.  */
 623     tree blocks;
 624
 625     /* The BLOCK node for this level, if one has been preallocated.
 626        If 0, the BLOCK is allocated (if needed) when the level is popped.  */
 627     tree this_block;
 628
 629     /* The binding level which this one is contained in (inherits from).  */
 630     struct binding_level *level_chain;
 631
 632     /* 0: no ffecom_prepare_* functions called at this level yet;
 633        1: ffecom_prepare* functions called, except not ffecom_prepare_end;
 634        2: ffecom_prepare_end called.  */
 635     int prep_state;
 636   };
 637
 638 #define NULL_BINDING_LEVEL (struct binding_level *) NULL
 639
 640 /* The binding level currently in effect.  */
 641
 642 static struct binding_level *current_binding_level;
 643
 644 /* A chain of binding_level structures awaiting reuse.  */
 645
 646 static struct binding_level *free_binding_level;
 647
 648 /* The outermost binding level, for names of file scope.
 649    This is created when the compiler is started and exists
 650    through the entire run.  */
 651
 652 static struct binding_level *global_binding_level;
 653
 654 /* Binding level structures are initialized by copying this one.  */
 655
 656 static struct binding_level clear_binding_level
 657 =
 658 {NULL, NULL, NULL, NULL_BINDING_LEVEL, 0};
 659
 660 /* Language-dependent contents of an identifier.  */
 661
 662 struct lang_identifier
 663   {
 664     struct tree_identifier ignore;
 665     tree global_value, local_value, label_value;
 666     bool invented;
 667   };
 668
 669 /* Macros for access to language-specific slots in an identifier.  */
 670 /* Each of these slots contains a DECL node or null.  */
 671
 672 /* This represents the value which the identifier has in the
 673    file-scope namespace.  */
 674 #define IDENTIFIER_GLOBAL_VALUE(NODE)   \
 675   (((struct lang_identifier *)(NODE))->global_value)
 676 /* This represents the value which the identifier has in the current
 677    scope.  */
 678 #define IDENTIFIER_LOCAL_VALUE(NODE)    \
 679   (((struct lang_identifier *)(NODE))->local_value)
 680 /* This represents the value which the identifier has as a label in
 681    the current label scope.  */
 682 #define IDENTIFIER_LABEL_VALUE(NODE)    \
 683   (((struct lang_identifier *)(NODE))->label_value)
 684 /* This is nonzero if the identifier was "made up" by g77 code.  */
 685 #define IDENTIFIER_INVENTED(NODE)       \
 686   (((struct lang_identifier *)(NODE))->invented)
 687
 688 /* In identifiers, C uses the following fields in a special way:
 689    TREE_PUBLIC        to record that there was a previous local extern decl.
 690    TREE_USED          to record that such a decl was used.
 691    TREE_ADDRESSABLE   to record that the address of such a decl was used.  */
 692
 693 /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
 694    that have names.  Here so we can clear out their names' definitions
 695    at the end of the function.  */
 696
 697 static tree named_labels;
 698
 699 /* A list of LABEL_DECLs from outer contexts that are currently shadowed.  */
 700
 701 static tree shadowed_labels;
 702
 703 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 704 \f
 705 /* Return the subscript expression, modified to do range-checking.
 706
 707    `array' is the array to be checked against.
 708    `element' is the subscript expression to check.
 709    `dim' is the dimension number (starting at 0).
 710    `total_dims' is the total number of dimensions (0 for CHARACTER substring).
 711 */
 712
 713 static tree
 714 ffecom_subscript_check_ (tree array, tree element, int dim, int total_dims,
 715                          const char *array_name)
 716 {
 717   tree low = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 718   tree high = TYPE_MAX_VALUE (TYPE_DOMAIN (array));
 719   tree cond;
 720   tree die;
 721   tree args;
 722
 723   if (element == error_mark_node)
 724     return element;
 725
 726   if (TREE_TYPE (low) != TREE_TYPE (element))
 727     {
 728       if (TYPE_PRECISION (TREE_TYPE (low))
 729           > TYPE_PRECISION (TREE_TYPE (element)))
 730         element = convert (TREE_TYPE (low), element);
 731       else
 732         {
 733           low = convert (TREE_TYPE (element), low);
 734           if (high)
 735             high = convert (TREE_TYPE (element), high);
 736         }
 737     }
 738
 739   element = ffecom_save_tree (element);
 740   cond = ffecom_2 (LE_EXPR, integer_type_node,
 741                    low,
 742                    element);
 743   if (high)
 744     {
 745       cond = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
 746                        cond,
 747                        ffecom_2 (LE_EXPR, integer_type_node,
 748                                  element,
 749                                  high));
 750     }
 751
 752   {
 753     int len;
 754     char *proc;
 755     char *var;
 756     tree arg3;
 757     tree arg2;
 758     tree arg1;
 759     tree arg4;
 760
 761     switch (total_dims)
 762       {
 763       case 0:
 764         var = xmalloc (strlen (array_name) + 20);
 765         sprintf (var, "%s[%s-substring]",
 766                  array_name,
 767                  dim ? "end" : "start");
 768         len = strlen (var) + 1;
 769         arg1 = build_string (len, var);
 770         free (var);
 771         break;
 772
 773       case 1:
 774         len = strlen (array_name) + 1;
 775         arg1 = build_string (len, array_name);
 776         break;
 777
 778       default:
 779         var = xmalloc (strlen (array_name) + 40);
 780         sprintf (var, "%s[subscript-%d-of-%d]",
 781                  array_name,
 782                  dim + 1, total_dims);
 783         len = strlen (var) + 1;
 784         arg1 = build_string (len, var);
 785         free (var);
 786         break;
 787       }
 788
 789     TREE_TYPE (arg1)
 790       = build_type_variant (build_array_type (char_type_node,
 791                                               build_range_type
 792                                               (integer_type_node,
 793                                                integer_one_node,
 794                                                build_int_2 (len, 0))),
 795                             1, 0);
 796     TREE_CONSTANT (arg1) = 1;
 797     TREE_STATIC (arg1) = 1;
 798     arg1 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg1)),
 799                      arg1);
 800
 801     /* s_rnge adds one to the element to print it, so bias against
 802        that -- want to print a faithful *subscript* value.  */
 803     arg2 = convert (ffecom_f2c_ftnint_type_node,
 804                     ffecom_2 (MINUS_EXPR,
 805                               TREE_TYPE (element),
 806                               element,
 807                               convert (TREE_TYPE (element),
 808                                        integer_one_node)));
 809
 810     proc = xmalloc ((len = strlen (input_filename)
 811                      + IDENTIFIER_LENGTH (DECL_NAME (current_function_decl))
 812                      + 2));
 813
 814     sprintf (&proc[0], "%s/%s",
 815              input_filename,
 816              IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
 817     arg3 = build_string (len, proc);
 818
 819     free (proc);
 820
 821     TREE_TYPE (arg3)
 822       = build_type_variant (build_array_type (char_type_node,
 823                                               build_range_type
 824                                               (integer_type_node,
 825                                                integer_one_node,
 826                                                build_int_2 (len, 0))),
 827                             1, 0);
 828     TREE_CONSTANT (arg3) = 1;
 829     TREE_STATIC (arg3) = 1;
 830     arg3 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg3)),
 831                      arg3);
 832
 833     arg4 = convert (ffecom_f2c_ftnint_type_node,
 834                     build_int_2 (lineno, 0));
 835
 836     arg1 = build_tree_list (NULL_TREE, arg1);
 837     arg2 = build_tree_list (NULL_TREE, arg2);
 838     arg3 = build_tree_list (NULL_TREE, arg3);
 839     arg4 = build_tree_list (NULL_TREE, arg4);
 840     TREE_CHAIN (arg3) = arg4;
 841     TREE_CHAIN (arg2) = arg3;
 842     TREE_CHAIN (arg1) = arg2;
 843
 844     args = arg1;
 845   }
 846   die = ffecom_call_gfrt (FFECOM_gfrtRANGE,
 847                           args, NULL_TREE);
 848   TREE_SIDE_EFFECTS (die) = 1;
 849
 850   element = ffecom_3 (COND_EXPR,
 851                       TREE_TYPE (element),
 852                       cond,
 853                       element,
 854                       die);
 855
 856   return element;
 857 }
 858
 859 /* Return the computed element of an array reference.
 860
 861    `item' is NULL_TREE, or the transformed pointer to the array.
 862    `expr' is the original opARRAYREF expression, which is transformed
 863      if `item' is NULL_TREE.
 864    `want_ptr' is non-zero if a pointer to the element, instead of
 865      the element itself, is to be returned.  */
 866
 867 static tree
 868 ffecom_arrayref_ (tree item, ffebld expr, int want_ptr)
 869 {
 870   ffebld dims[FFECOM_dimensionsMAX];
 871   int i;
 872   int total_dims;
 873   int flatten = ffe_is_flatten_arrays ();
 874   int need_ptr;
 875   tree array;
 876   tree element;
 877   tree tree_type;
 878   tree tree_type_x;
 879   const char *array_name;
 880   ffetype type;
 881   ffebld list;
 882
 883   if (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER)
 884     array_name = ffesymbol_text (ffebld_symter (ffebld_left (expr)));
 885   else
 886     array_name = "[expr?]";
 887
 888   /* Build up ARRAY_REFs in reverse order (since we're column major
 889      here in Fortran land). */
 890
 891   for (i = 0, list = ffebld_right (expr);
 892        list != NULL;
 893        ++i, list = ffebld_trail (list))
 894     {
 895       dims[i] = ffebld_head (list);
 896       type = ffeinfo_type (ffebld_basictype (dims[i]),
 897                            ffebld_kindtype (dims[i]));
 898       if (! flatten
 899           && ffecom_typesize_pointer_ > ffecom_typesize_integer1_
 900           && ffetype_size (type) > ffecom_typesize_integer1_)
 901         /* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit
 902            pointers and 32-bit integers.  Do the full 64-bit pointer
 903            arithmetic, for codes using arrays for nonstandard heap-like
 904            work.  */
 905         flatten = 1;
 906     }
 907
 908   total_dims = i;
 909
 910   need_ptr = want_ptr || flatten;
 911
 912   if (! item)
 913     {
 914       if (need_ptr)
 915         item = ffecom_ptr_to_expr (ffebld_left (expr));
 916       else
 917         item = ffecom_expr (ffebld_left (expr));
 918
 919       if (item == error_mark_node)
 920         return item;
 921
 922       if (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING
 923           && ! mark_addressable (item))
 924         return error_mark_node;
 925     }
 926
 927   if (item == error_mark_node)
 928     return item;
 929
 930   if (need_ptr)
 931     {
 932       tree min;
 933
 934       for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
 935            i >= 0;
 936            --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
 937         {
 938           min = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 939           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 940           if (flag_bounds_check)
 941             element = ffecom_subscript_check_ (array, element, i, total_dims,
 942                                                array_name);
 943           if (element == error_mark_node)
 944             return element;
 945
 946           /* Widen integral arithmetic as desired while preserving
 947              signedness.  */
 948           tree_type = TREE_TYPE (element);
 949           tree_type_x = tree_type;
 950           if (tree_type
 951               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
 952               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
 953             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
 954
 955           if (TREE_TYPE (min) != tree_type_x)
 956             min = convert (tree_type_x, min);
 957           if (TREE_TYPE (element) != tree_type_x)
 958             element = convert (tree_type_x, element);
 959
 960           item = ffecom_2 (PLUS_EXPR,
 961                            build_pointer_type (TREE_TYPE (array)),
 962                            item,
 963                            size_binop (MULT_EXPR,
 964                                        size_in_bytes (TREE_TYPE (array)),
 965                                        convert (sizetype,
 966                                                 fold (build (MINUS_EXPR,
 967                                                              tree_type_x,
 968                                                              element, min)))));
 969         }
 970       if (! want_ptr)
 971         {
 972           item = ffecom_1 (INDIRECT_REF,
 973                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
 974                            item);
 975         }
 976     }
 977   else
 978     {
 979       for (--i;
 980            i >= 0;
 981            --i)
 982         {
 983           array = TYPE_MAIN_VARIANT (TREE_TYPE (item));
 984
 985           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 986           if (flag_bounds_check)
 987             element = ffecom_subscript_check_ (array, element, i, total_dims,
 988                                                array_name);
 989           if (element == error_mark_node)
 990             return element;
 991
 992           /* Widen integral arithmetic as desired while preserving
 993              signedness.  */
 994           tree_type = TREE_TYPE (element);
 995           tree_type_x = tree_type;
 996           if (tree_type
 997               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
 998               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
 999             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
1000
1001           element = convert (tree_type_x, element);
1002
1003           item = ffecom_2 (ARRAY_REF,
1004                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
1005                            item,
1006                            element);
1007         }
1008     }
1009
1010   return item;
1011 }
1012
1013 /* This is like gcc's stabilize_reference -- in fact, most of the code
1014    comes from that -- but it handles the situation where the reference
1015    is going to have its subparts picked at, and it shouldn't change
1016    (or trigger extra invocations of functions in the subtrees) due to
1017    this.  save_expr is a bit overzealous, because we don't need the
1018    entire thing calculated and saved like a temp.  So, for DECLs, no
1019    change is needed, because these are stable aggregates, and ARRAY_REF
1020    and such might well be stable too, but for things like calculations,
1021    we do need to calculate a snapshot of a value before picking at it.  */
1022
1023 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1024 static tree
1025 ffecom_stabilize_aggregate_ (tree ref)
1026 {
1027   tree result;
1028   enum tree_code code = TREE_CODE (ref);
1029
1030   switch (code)
1031     {
1032     case VAR_DECL:
1033     case PARM_DECL:
1034     case RESULT_DECL:
1035       /* No action is needed in this case.  */
1036       return ref;
1037
1038     case NOP_EXPR:
1039     case CONVERT_EXPR:
1040     case FLOAT_EXPR:
1041     case FIX_TRUNC_EXPR:
1042     case FIX_FLOOR_EXPR:
1043     case FIX_ROUND_EXPR:
1044     case FIX_CEIL_EXPR:
1045       result = build_nt (code, stabilize_reference (TREE_OPERAND (ref, 0)));
1046       break;
1047
1048     case INDIRECT_REF:
1049       result = build_nt (INDIRECT_REF,
1050                          stabilize_reference_1 (TREE_OPERAND (ref, 0)));
1051       break;
1052
1053     case COMPONENT_REF:
1054       result = build_nt (COMPONENT_REF,
1055                          stabilize_reference (TREE_OPERAND (ref, 0)),
1056                          TREE_OPERAND (ref, 1));
1057       break;
1058
1059     case BIT_FIELD_REF:
1060       result = build_nt (BIT_FIELD_REF,
1061                          stabilize_reference (TREE_OPERAND (ref, 0)),
1062                          stabilize_reference_1 (TREE_OPERAND (ref, 1)),
1063                          stabilize_reference_1 (TREE_OPERAND (ref, 2)));
1064       break;
1065
1066     case ARRAY_REF:
1067       result = build_nt (ARRAY_REF,
1068                          stabilize_reference (TREE_OPERAND (ref, 0)),
1069                          stabilize_reference_1 (TREE_OPERAND (ref, 1)));
1070       break;
1071
1072     case COMPOUND_EXPR:
1073       result = build_nt (COMPOUND_EXPR,
1074                          stabilize_reference_1 (TREE_OPERAND (ref, 0)),
1075                          stabilize_reference (TREE_OPERAND (ref, 1)));
1076       break;
1077
1078     case RTL_EXPR:
1079       result = build1 (INDIRECT_REF, TREE_TYPE (ref),
1080                        save_expr (build1 (ADDR_EXPR,
1081                                           build_pointer_type (TREE_TYPE (ref)),
1082                                           ref)));
1083       break;
1084
1085
1086     default:
1087       return save_expr (ref);
1088
1089     case ERROR_MARK:
1090       return error_mark_node;
1091     }
1092
1093   TREE_TYPE (result) = TREE_TYPE (ref);
1094   TREE_READONLY (result) = TREE_READONLY (ref);
1095   TREE_SIDE_EFFECTS (result) = TREE_SIDE_EFFECTS (ref);
1096   TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
1097
1098   return result;
1099 }
1100 #endif
1101
1102 /* A rip-off of gcc's convert.c convert_to_complex function,
1103    reworked to handle complex implemented as C structures
1104    (RECORD_TYPE with two fields, real and imaginary `r' and `i').  */
1105
1106 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1107 static tree
1108 ffecom_convert_to_complex_ (tree type, tree expr)
1109 {
1110   register enum tree_code form = TREE_CODE (TREE_TYPE (expr));
1111   tree subtype;
1112
1113   assert (TREE_CODE (type) == RECORD_TYPE);
1114
1115   subtype = TREE_TYPE (TYPE_FIELDS (type));
1116
1117   if (form == REAL_TYPE || form == INTEGER_TYPE || form == ENUMERAL_TYPE)
1118     {
1119       expr = convert (subtype, expr);
1120       return ffecom_2 (COMPLEX_EXPR, type, expr,
1121                        convert (subtype, integer_zero_node));
1122     }
1123
1124   if (form == RECORD_TYPE)
1125     {
1126       tree elt_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr)));
1127       if (TYPE_MAIN_VARIANT (elt_type) == TYPE_MAIN_VARIANT (subtype))
1128         return expr;
1129       else
1130         {
1131           expr = save_expr (expr);
1132           return ffecom_2 (COMPLEX_EXPR,
1133                            type,
1134                            convert (subtype,
1135                                     ffecom_1 (REALPART_EXPR,
1136                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1137                                               expr)),
1138                            convert (subtype,
1139                                     ffecom_1 (IMAGPART_EXPR,
1140                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1141                                               expr)));
1142         }
1143     }
1144
1145   if (form == POINTER_TYPE || form == REFERENCE_TYPE)
1146     error ("pointer value used where a complex was expected");
1147   else
1148     error ("aggregate value used where a complex was expected");
1149
1150   return ffecom_2 (COMPLEX_EXPR, type,
1151                    convert (subtype, integer_zero_node),
1152                    convert (subtype, integer_zero_node));
1153 }
1154 #endif
1155
1156 /* Like gcc's convert(), but crashes if widening might happen.  */
1157
1158 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1159 static tree
1160 ffecom_convert_narrow_ (type, expr)
1161      tree type, expr;
1162 {
1163   register tree e = expr;
1164   register enum tree_code code = TREE_CODE (type);
1165
1166   if (type == TREE_TYPE (e)
1167       || TREE_CODE (e) == ERROR_MARK)
1168     return e;
1169   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1170     return fold (build1 (NOP_EXPR, type, e));
1171   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1172       || code == ERROR_MARK)
1173     return error_mark_node;
1174   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1175     {
1176       assert ("void value not ignored as it ought to be" == NULL);
1177       return error_mark_node;
1178     }
1179   assert (code != VOID_TYPE);
1180   if ((code != RECORD_TYPE)
1181       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1182     assert ("converting COMPLEX to REAL" == NULL);
1183   assert (code != ENUMERAL_TYPE);
1184   if (code == INTEGER_TYPE)
1185     {
1186       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1187                && TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)))
1188               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1189                   && (TYPE_PRECISION (type)
1190                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1191       return fold (convert_to_integer (type, e));
1192     }
1193   if (code == POINTER_TYPE)
1194     {
1195       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1196       return fold (convert_to_pointer (type, e));
1197     }
1198   if (code == REAL_TYPE)
1199     {
1200       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1201       assert (TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)));
1202       return fold (convert_to_real (type, e));
1203     }
1204   if (code == COMPLEX_TYPE)
1205     {
1206       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1207       assert (TYPE_PRECISION (TREE_TYPE (type)) <= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1208       return fold (convert_to_complex (type, e));
1209     }
1210   if (code == RECORD_TYPE)
1211     {
1212       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1213       /* Check that at least the first field name agrees.  */
1214       assert (DECL_NAME (TYPE_FIELDS (type))
1215               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1216       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1217               <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1218       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1219           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1220         return e;
1221       return fold (ffecom_convert_to_complex_ (type, e));
1222     }
1223
1224   assert ("conversion to non-scalar type requested" == NULL);
1225   return error_mark_node;
1226 }
1227 #endif
1228
1229 /* Like gcc's convert(), but crashes if narrowing might happen.  */
1230
1231 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1232 static tree
1233 ffecom_convert_widen_ (type, expr)
1234      tree type, expr;
1235 {
1236   register tree e = expr;
1237   register enum tree_code code = TREE_CODE (type);
1238
1239   if (type == TREE_TYPE (e)
1240       || TREE_CODE (e) == ERROR_MARK)
1241     return e;
1242   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1243     return fold (build1 (NOP_EXPR, type, e));
1244   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1245       || code == ERROR_MARK)
1246     return error_mark_node;
1247   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1248     {
1249       assert ("void value not ignored as it ought to be" == NULL);
1250       return error_mark_node;
1251     }
1252   assert (code != VOID_TYPE);
1253   if ((code != RECORD_TYPE)
1254       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1255     assert ("narrowing COMPLEX to REAL" == NULL);
1256   assert (code != ENUMERAL_TYPE);
1257   if (code == INTEGER_TYPE)
1258     {
1259       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1260                && TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)))
1261               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1262                   && (TYPE_PRECISION (type)
1263                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1264       return fold (convert_to_integer (type, e));
1265     }
1266   if (code == POINTER_TYPE)
1267     {
1268       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1269       return fold (convert_to_pointer (type, e));
1270     }
1271   if (code == REAL_TYPE)
1272     {
1273       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1274       assert (TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)));
1275       return fold (convert_to_real (type, e));
1276     }
1277   if (code == COMPLEX_TYPE)
1278     {
1279       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1280       assert (TYPE_PRECISION (TREE_TYPE (type)) >= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1281       return fold (convert_to_complex (type, e));
1282     }
1283   if (code == RECORD_TYPE)
1284     {
1285       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1286       /* Check that at least the first field name agrees.  */
1287       assert (DECL_NAME (TYPE_FIELDS (type))
1288               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1289       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1290               >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1291       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1292           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1293         return e;
1294       return fold (ffecom_convert_to_complex_ (type, e));
1295     }
1296
1297   assert ("conversion to non-scalar type requested" == NULL);
1298   return error_mark_node;
1299 }
1300 #endif
1301
1302 /* Handles making a COMPLEX type, either the standard
1303    (but buggy?) gbe way, or the safer (but less elegant?)
1304    f2c way.  */
1305
1306 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1307 static tree
1308 ffecom_make_complex_type_ (tree subtype)
1309 {
1310   tree type;
1311   tree realfield;
1312   tree imagfield;
1313
1314   if (ffe_is_emulate_complex ())
1315     {
1316       type = make_node (RECORD_TYPE);
1317       realfield = ffecom_decl_field (type, NULL_TREE, "r", subtype);
1318       imagfield = ffecom_decl_field (type, realfield, "i", subtype);
1319       TYPE_FIELDS (type) = realfield;
1320       layout_type (type);
1321     }
1322   else
1323     {
1324       type = make_node (COMPLEX_TYPE);
1325       TREE_TYPE (type) = subtype;
1326       layout_type (type);
1327     }
1328
1329   return type;
1330 }
1331 #endif
1332
1333 /* Chooses either the gbe or the f2c way to build a
1334    complex constant.  */
1335
1336 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1337 static tree
1338 ffecom_build_complex_constant_ (tree type, tree realpart, tree imagpart)
1339 {
1340   tree bothparts;
1341
1342   if (ffe_is_emulate_complex ())
1343     {
1344       bothparts = build_tree_list (TYPE_FIELDS (type), realpart);
1345       TREE_CHAIN (bothparts) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), imagpart);
1346       bothparts = build (CONSTRUCTOR, type, NULL_TREE, bothparts);
1347     }
1348   else
1349     {
1350       bothparts = build_complex (type, realpart, imagpart);
1351     }
1352
1353   return bothparts;
1354 }
1355 #endif
1356
1357 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1358 static tree
1359 ffecom_arglist_expr_ (const char *c, ffebld expr)
1360 {
1361   tree list;
1362   tree *plist = &list;
1363   tree trail = NULL_TREE;       /* Append char length args here. */
1364   tree *ptrail = &trail;
1365   tree length;
1366   ffebld exprh;
1367   tree item;
1368   bool ptr = FALSE;
1369   tree wanted = NULL_TREE;
1370   static char zed[] = "0";
1371
1372   if (c == NULL)
1373     c = &zed[0];
1374
1375   while (expr != NULL)
1376     {
1377       if (*c != '\0')
1378         {
1379           ptr = FALSE;
1380           if (*c == '&')
1381             {
1382               ptr = TRUE;
1383               ++c;
1384             }
1385           switch (*(c++))
1386             {
1387             case '\0':
1388               ptr = TRUE;
1389               wanted = NULL_TREE;
1390               break;
1391
1392             case 'a':
1393               assert (ptr);
1394               wanted = NULL_TREE;
1395               break;
1396
1397             case 'c':
1398               wanted = ffecom_f2c_complex_type_node;
1399               break;
1400
1401             case 'd':
1402               wanted = ffecom_f2c_doublereal_type_node;
1403               break;
1404
1405             case 'e':
1406               wanted = ffecom_f2c_doublecomplex_type_node;
1407               break;
1408
1409             case 'f':
1410               wanted = ffecom_f2c_real_type_node;
1411               break;
1412
1413             case 'i':
1414               wanted = ffecom_f2c_integer_type_node;
1415               break;
1416
1417             case 'j':
1418               wanted = ffecom_f2c_longint_type_node;
1419               break;
1420
1421             default:
1422               assert ("bad argstring code" == NULL);
1423               wanted = NULL_TREE;
1424               break;
1425             }
1426         }
1427
1428       exprh = ffebld_head (expr);
1429       if (exprh == NULL)
1430         wanted = NULL_TREE;
1431
1432       if ((wanted == NULL_TREE)
1433           || (ptr
1434               && (TYPE_MODE
1435                   (ffecom_tree_type[ffeinfo_basictype (ffebld_info (exprh))]
1436                    [ffeinfo_kindtype (ffebld_info (exprh))])
1437                    == TYPE_MODE (wanted))))
1438         *plist
1439           = build_tree_list (NULL_TREE,
1440                              ffecom_arg_ptr_to_expr (exprh,
1441                                                      &length));
1442       else
1443         {
1444           item = ffecom_arg_expr (exprh, &length);
1445           item = ffecom_convert_widen_ (wanted, item);
1446           if (ptr)
1447             {
1448               item = ffecom_1 (ADDR_EXPR,
1449                                build_pointer_type (TREE_TYPE (item)),
1450                                item);
1451             }
1452           *plist
1453             = build_tree_list (NULL_TREE,
1454                                item);
1455         }
1456
1457       plist = &TREE_CHAIN (*plist);
1458       expr = ffebld_trail (expr);
1459       if (length != NULL_TREE)
1460         {
1461           *ptrail = build_tree_list (NULL_TREE, length);
1462           ptrail = &TREE_CHAIN (*ptrail);
1463         }
1464     }
1465
1466   /* We've run out of args in the call; if the implementation expects
1467      more, supply null pointers for them, which the implementation can
1468      check to see if an arg was omitted. */
1469
1470   while (*c != '\0' && *c != '0')
1471     {
1472       if (*c == '&')
1473         ++c;
1474       else
1475         assert ("missing arg to run-time routine!" == NULL);
1476
1477       switch (*(c++))
1478         {
1479         case '\0':
1480         case 'a':
1481         case 'c':
1482         case 'd':
1483         case 'e':
1484         case 'f':
1485         case 'i':
1486         case 'j':
1487           break;
1488
1489         default:
1490           assert ("bad arg string code" == NULL);
1491           break;
1492         }
1493       *plist
1494         = build_tree_list (NULL_TREE,
1495                            null_pointer_node);
1496       plist = &TREE_CHAIN (*plist);
1497     }
1498
1499   *plist = trail;
1500
1501   return list;
1502 }
1503 #endif
1504
1505 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1506 static tree
1507 ffecom_widest_expr_type_ (ffebld list)
1508 {
1509   ffebld item;
1510   ffebld widest = NULL;
1511   ffetype type;
1512   ffetype widest_type = NULL;
1513   tree t;
1514
1515   for (; list != NULL; list = ffebld_trail (list))
1516     {
1517       item = ffebld_head (list);
1518       if (item == NULL)
1519         continue;
1520       if ((widest != NULL)
1521           && (ffeinfo_basictype (ffebld_info (item))
1522               != ffeinfo_basictype (ffebld_info (widest))))
1523         continue;
1524       type = ffeinfo_type (ffeinfo_basictype (ffebld_info (item)),
1525                            ffeinfo_kindtype (ffebld_info (item)));
1526       if ((widest == FFEINFO_kindtypeNONE)
1527           || (ffetype_size (type)
1528               > ffetype_size (widest_type)))
1529         {
1530           widest = item;
1531           widest_type = type;
1532         }
1533     }
1534
1535   assert (widest != NULL);
1536   t = ffecom_tree_type[ffeinfo_basictype (ffebld_info (widest))]
1537     [ffeinfo_kindtype (ffebld_info (widest))];
1538   assert (t != NULL_TREE);
1539   return t;
1540 }
1541 #endif
1542
1543 /* Check whether a partial overlap between two expressions is possible.
1544
1545    Can *starting* to write a portion of expr1 change the value
1546    computed (perhaps already, *partially*) by expr2?
1547
1548    Currently, this is a concern only for a COMPLEX expr1.  But if it
1549    isn't in COMMON or local EQUIVALENCE, since we don't support
1550    aliasing of arguments, it isn't a concern.  */
1551
1552 static bool
1553 ffecom_possible_partial_overlap_ (ffebld expr1, ffebld expr2 ATTRIBUTE_UNUSED)
1554 {
1555   ffesymbol sym;
1556   ffestorag st;
1557
1558   switch (ffebld_op (expr1))
1559     {
1560     case FFEBLD_opSYMTER:
1561       sym = ffebld_symter (expr1);
1562       break;
1563
1564     case FFEBLD_opARRAYREF:
1565       if (ffebld_op (ffebld_left (expr1)) != FFEBLD_opSYMTER)
1566         return FALSE;
1567       sym = ffebld_symter (ffebld_left (expr1));
1568       break;
1569
1570     default:
1571       return FALSE;
1572     }
1573
1574   if (ffesymbol_where (sym) != FFEINFO_whereCOMMON
1575       && (ffesymbol_where (sym) != FFEINFO_whereLOCAL
1576           || ! (st = ffesymbol_storage (sym))
1577           || ! ffestorag_parent (st)))
1578     return FALSE;
1579
1580   /* It's in COMMON or local EQUIVALENCE.  */
1581
1582   return TRUE;
1583 }
1584
1585 /* Check whether dest and source might overlap.  ffebld versions of these
1586    might or might not be passed, will be NULL if not.
1587
1588    The test is really whether source_tree is modifiable and, if modified,
1589    might overlap destination such that the value(s) in the destination might
1590    change before it is finally modified.  dest_* are the canonized
1591    destination itself.  */
1592
1593 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1594 static bool
1595 ffecom_overlap_ (tree dest_decl, tree dest_offset, tree dest_size,
1596                  tree source_tree, ffebld source UNUSED,
1597                  bool scalar_arg)
1598 {
1599   tree source_decl;
1600   tree source_offset;
1601   tree source_size;
1602   tree t;
1603
1604   if (source_tree == NULL_TREE)
1605     return FALSE;
1606
1607   switch (TREE_CODE (source_tree))
1608     {
1609     case ERROR_MARK:
1610     case IDENTIFIER_NODE:
1611     case INTEGER_CST:
1612     case REAL_CST:
1613     case COMPLEX_CST:
1614     case STRING_CST:
1615     case CONST_DECL:
1616     case VAR_DECL:
1617     case RESULT_DECL:
1618     case FIELD_DECL:
1619     case MINUS_EXPR:
1620     case MULT_EXPR:
1621     case TRUNC_DIV_EXPR:
1622     case CEIL_DIV_EXPR:
1623     case FLOOR_DIV_EXPR:
1624     case ROUND_DIV_EXPR:
1625     case TRUNC_MOD_EXPR:
1626     case CEIL_MOD_EXPR:
1627     case FLOOR_MOD_EXPR:
1628     case ROUND_MOD_EXPR:
1629     case RDIV_EXPR:
1630     case EXACT_DIV_EXPR:
1631     case FIX_TRUNC_EXPR:
1632     case FIX_CEIL_EXPR:
1633     case FIX_FLOOR_EXPR:
1634     case FIX_ROUND_EXPR:
1635     case FLOAT_EXPR:
1636     case EXPON_EXPR:
1637     case NEGATE_EXPR:
1638     case MIN_EXPR:
1639     case MAX_EXPR:
1640     case ABS_EXPR:
1641     case FFS_EXPR:
1642     case LSHIFT_EXPR:
1643     case RSHIFT_EXPR:
1644     case LROTATE_EXPR:
1645     case RROTATE_EXPR:
1646     case BIT_IOR_EXPR:
1647     case BIT_XOR_EXPR:
1648     case BIT_AND_EXPR:
1649     case BIT_ANDTC_EXPR:
1650     case BIT_NOT_EXPR:
1651     case TRUTH_ANDIF_EXPR:
1652     case TRUTH_ORIF_EXPR:
1653     case TRUTH_AND_EXPR:
1654     case TRUTH_OR_EXPR:
1655     case TRUTH_XOR_EXPR:
1656     case TRUTH_NOT_EXPR:
1657     case LT_EXPR:
1658     case LE_EXPR:
1659     case GT_EXPR:
1660     case GE_EXPR:
1661     case EQ_EXPR:
1662     case NE_EXPR:
1663     case COMPLEX_EXPR:
1664     case CONJ_EXPR:
1665     case REALPART_EXPR:
1666     case IMAGPART_EXPR:
1667     case LABEL_EXPR:
1668     case COMPONENT_REF:
1669       return FALSE;
1670
1671     case COMPOUND_EXPR:
1672       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1673                               TREE_OPERAND (source_tree, 1), NULL,
1674                               scalar_arg);
1675
1676     case MODIFY_EXPR:
1677       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1678                               TREE_OPERAND (source_tree, 0), NULL,
1679                               scalar_arg);
1680
1681     case CONVERT_EXPR:
1682     case NOP_EXPR:
1683     case NON_LVALUE_EXPR:
1684     case PLUS_EXPR:
1685       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1686         return TRUE;
1687
1688       ffecom_tree_canonize_ptr_ (&source_decl, &source_offset,
1689                                  source_tree);
1690       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1691       break;
1692
1693     case COND_EXPR:
1694       return
1695         ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1696                          TREE_OPERAND (source_tree, 1), NULL,
1697                          scalar_arg)
1698           || ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1699                               TREE_OPERAND (source_tree, 2), NULL,
1700                               scalar_arg);
1701
1702
1703     case ADDR_EXPR:
1704       ffecom_tree_canonize_ref_ (&source_decl, &source_offset,
1705                                  &source_size,
1706                                  TREE_OPERAND (source_tree, 0));
1707       break;
1708
1709     case PARM_DECL:
1710       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1711         return TRUE;
1712
1713       source_decl = source_tree;
1714       source_offset = bitsize_zero_node;
1715       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1716       break;
1717
1718     case SAVE_EXPR:
1719     case REFERENCE_EXPR:
1720     case PREDECREMENT_EXPR:
1721     case PREINCREMENT_EXPR:
1722     case POSTDECREMENT_EXPR:
1723     case POSTINCREMENT_EXPR:
1724     case INDIRECT_REF:
1725     case ARRAY_REF:
1726     case CALL_EXPR:
1727     default:
1728       return TRUE;
1729     }
1730
1731   /* Come here when source_decl, source_offset, and source_size filled
1732      in appropriately.  */
1733
1734   if (source_decl == NULL_TREE)
1735     return FALSE;               /* No decl involved, so no overlap. */
1736
1737   if (source_decl != dest_decl)
1738     return FALSE;               /* Different decl, no overlap. */
1739
1740   if (TREE_CODE (dest_size) == ERROR_MARK)
1741     return TRUE;                /* Assignment into entire assumed-size
1742                                    array?  Shouldn't happen.... */
1743
1744   t = ffecom_2 (LE_EXPR, integer_type_node,
1745                 ffecom_2 (PLUS_EXPR, TREE_TYPE (dest_offset),
1746                           dest_offset,
1747                           convert (TREE_TYPE (dest_offset),
1748                                    dest_size)),
1749                 convert (TREE_TYPE (dest_offset),
1750                          source_offset));
1751
1752   if (integer_onep (t))
1753     return FALSE;               /* Destination precedes source. */
1754
1755   if (!scalar_arg
1756       || (source_size == NULL_TREE)
1757       || (TREE_CODE (source_size) == ERROR_MARK)
1758       || integer_zerop (source_size))
1759     return TRUE;                /* No way to tell if dest follows source. */
1760
1761   t = ffecom_2 (LE_EXPR, integer_type_node,
1762                 ffecom_2 (PLUS_EXPR, TREE_TYPE (source_offset),
1763                           source_offset,
1764                           convert (TREE_TYPE (source_offset),
1765                                    source_size)),
1766                 convert (TREE_TYPE (source_offset),
1767                          dest_offset));
1768
1769   if (integer_onep (t))
1770     return FALSE;               /* Destination follows source. */
1771
1772   return TRUE;          /* Destination and source overlap. */
1773 }
1774 #endif
1775
1776 /* Check whether dest might overlap any of a list of arguments or is
1777    in a COMMON area the callee might know about (and thus modify).  */
1778
1779 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1780 static bool
1781 ffecom_args_overlapping_ (tree dest_tree, ffebld dest UNUSED,
1782                           tree args, tree callee_commons,
1783                           bool scalar_args)
1784 {
1785   tree arg;
1786   tree dest_decl;
1787   tree dest_offset;
1788   tree dest_size;
1789
1790   ffecom_tree_canonize_ref_ (&dest_decl, &dest_offset, &dest_size,
1791                              dest_tree);
1792
1793   if (dest_decl == NULL_TREE)
1794     return FALSE;               /* Seems unlikely! */
1795
1796   /* If the decl cannot be determined reliably, or if its in COMMON
1797      and the callee isn't known to not futz with COMMON via other
1798      means, overlap might happen.  */
1799
1800   if ((TREE_CODE (dest_decl) == ERROR_MARK)
1801       || ((callee_commons != NULL_TREE)
1802           && TREE_PUBLIC (dest_decl)))
1803     return TRUE;
1804
1805   for (; args != NULL_TREE; args = TREE_CHAIN (args))
1806     {
1807       if (((arg = TREE_VALUE (args)) != NULL_TREE)
1808           && ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1809                               arg, NULL, scalar_args))
1810         return TRUE;
1811     }
1812
1813   return FALSE;
1814 }
1815 #endif
1816
1817 /* Build a string for a variable name as used by NAMELIST.  This means that
1818    if we're using the f2c library, we build an uppercase string, since
1819    f2c does this.  */
1820
1821 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1822 static tree
1823 ffecom_build_f2c_string_ (int i, const char *s)
1824 {
1825   if (!ffe_is_f2c_library ())
1826     return build_string (i, s);
1827
1828   {
1829     char *tmp;
1830     const char *p;
1831     char *q;
1832     char space[34];
1833     tree t;
1834
1835     if (((size_t) i) > ARRAY_SIZE (space))
1836       tmp = malloc_new_ks (malloc_pool_image (), "f2c_string", i);
1837     else
1838       tmp = &space[0];
1839
1840     for (p = s, q = tmp; *p != '\0'; ++p, ++q)
1841       *q = ffesrc_toupper (*p);
1842     *q = '\0';
1843
1844     t = build_string (i, tmp);
1845
1846     if (((size_t) i) > ARRAY_SIZE (space))
1847       malloc_kill_ks (malloc_pool_image (), tmp, i);
1848
1849     return t;
1850   }
1851 }
1852
1853 #endif
1854 /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
1855    type to just get whatever the function returns), handling the
1856    f2c value-returning convention, if required, by prepending
1857    to the arglist a pointer to a temporary to receive the return value.  */
1858
1859 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1860 static tree
1861 ffecom_call_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1862               tree type, tree args, tree dest_tree,
1863               ffebld dest, bool *dest_used, tree callee_commons,
1864               bool scalar_args, tree hook)
1865 {
1866   tree item;
1867   tree tempvar;
1868
1869   if (dest_used != NULL)
1870     *dest_used = FALSE;
1871
1872   if (is_f2c_complex)
1873     {
1874       if ((dest_used == NULL)
1875           || (dest == NULL)
1876           || (ffeinfo_basictype (ffebld_info (dest))
1877               != FFEINFO_basictypeCOMPLEX)
1878           || (ffeinfo_kindtype (ffebld_info (dest)) != kt)
1879           || ((type != NULL_TREE) && (TREE_TYPE (dest_tree) != type))
1880           || ffecom_args_overlapping_ (dest_tree, dest, args,
1881                                        callee_commons,
1882                                        scalar_args))
1883         {
1884 #ifdef HOHO
1885           tempvar = ffecom_make_tempvar (ffecom_tree_type
1886                                          [FFEINFO_basictypeCOMPLEX][kt],
1887                                          FFETARGET_charactersizeNONE,
1888                                          -1);
1889 #else
1890           tempvar = hook;
1891           assert (tempvar);
1892 #endif
1893         }
1894       else
1895         {
1896           *dest_used = TRUE;
1897           tempvar = dest_tree;
1898           type = NULL_TREE;
1899         }
1900
1901       item
1902         = build_tree_list (NULL_TREE,
1903                            ffecom_1 (ADDR_EXPR,
1904                                      build_pointer_type (TREE_TYPE (tempvar)),
1905                                      tempvar));
1906       TREE_CHAIN (item) = args;
1907
1908       item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1909                         item, NULL_TREE);
1910
1911       if (tempvar != dest_tree)
1912         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item, tempvar);
1913     }
1914   else
1915     item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1916                       args, NULL_TREE);
1917
1918   if ((type != NULL_TREE) && (TREE_TYPE (item) != type))
1919     item = ffecom_convert_narrow_ (type, item);
1920
1921   return item;
1922 }
1923 #endif
1924
1925 /* Given two arguments, transform them and make a call to the given
1926    function via ffecom_call_.  */
1927
1928 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1929 static tree
1930 ffecom_call_binop_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1931                     tree type, ffebld left, ffebld right,
1932                     tree dest_tree, ffebld dest, bool *dest_used,
1933                     tree callee_commons, bool scalar_args, tree hook)
1934 {
1935   tree left_tree;
1936   tree right_tree;
1937   tree left_length;
1938   tree right_length;
1939
1940   left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
1941   right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
1942
1943   left_tree = build_tree_list (NULL_TREE, left_tree);
1944   right_tree = build_tree_list (NULL_TREE, right_tree);
1945   TREE_CHAIN (left_tree) = right_tree;
1946
1947   if (left_length != NULL_TREE)
1948     {
1949       left_length = build_tree_list (NULL_TREE, left_length);
1950       TREE_CHAIN (right_tree) = left_length;
1951     }
1952
1953   if (right_length != NULL_TREE)
1954     {
1955       right_length = build_tree_list (NULL_TREE, right_length);
1956       if (left_length != NULL_TREE)
1957         TREE_CHAIN (left_length) = right_length;
1958       else
1959         TREE_CHAIN (right_tree) = right_length;
1960     }
1961
1962   return ffecom_call_ (fn, kt, is_f2c_complex, type, left_tree,
1963                        dest_tree, dest, dest_used, callee_commons,
1964                        scalar_args, hook);
1965 }
1966 #endif
1967
1968 /* Return ptr/length args for char subexpression
1969
1970    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
1971    subexpressions by constructing the appropriate trees for the ptr-to-
1972    character-text and length-of-character-text arguments in a calling
1973    sequence.
1974
1975    Note that if with_null is TRUE, and the expression is an opCONTER,
1976    a null byte is appended to the string.  */
1977
1978 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1979 static void
1980 ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null)
1981 {
1982   tree item;
1983   tree high;
1984   ffetargetCharacter1 val;
1985   ffetargetCharacterSize newlen;
1986
1987   switch (ffebld_op (expr))
1988     {
1989     case FFEBLD_opCONTER:
1990       val = ffebld_constant_character1 (ffebld_conter (expr));
1991       newlen = ffetarget_length_character1 (val);
1992       if (with_null)
1993         {
1994           /* Begin FFETARGET-NULL-KLUDGE.  */
1995           if (newlen != 0)
1996             ++newlen;
1997         }
1998       *length = build_int_2 (newlen, 0);
1999       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2000       high = build_int_2 (newlen, 0);
2001       TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
2002       item = build_string (newlen,
2003                            ffetarget_text_character1 (val));
2004       /* End FFETARGET-NULL-KLUDGE.  */
2005       TREE_TYPE (item)
2006         = build_type_variant
2007           (build_array_type
2008            (char_type_node,
2009             build_range_type
2010             (ffecom_f2c_ftnlen_type_node,
2011              ffecom_f2c_ftnlen_one_node,
2012              high)),
2013            1, 0);
2014       TREE_CONSTANT (item) = 1;
2015       TREE_STATIC (item) = 1;
2016       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
2017                        item);
2018       break;
2019
2020     case FFEBLD_opSYMTER:
2021       {
2022         ffesymbol s = ffebld_symter (expr);
2023
2024         item = ffesymbol_hook (s).decl_tree;
2025         if (item == NULL_TREE)
2026           {
2027             s = ffecom_sym_transform_ (s);
2028             item = ffesymbol_hook (s).decl_tree;
2029           }
2030         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
2031           {
2032             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
2033               *length = ffesymbol_hook (s).length_tree;
2034             else
2035               {
2036                 *length = build_int_2 (ffesymbol_size (s), 0);
2037                 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2038               }
2039           }
2040         else if (item == error_mark_node)
2041           *length = error_mark_node;
2042         else
2043           /* FFEINFO_kindFUNCTION.  */
2044           *length = NULL_TREE;
2045         if (!ffesymbol_hook (s).addr
2046             && (item != error_mark_node))
2047           item = ffecom_1 (ADDR_EXPR,
2048                            build_pointer_type (TREE_TYPE (item)),
2049                            item);
2050       }
2051       break;
2052
2053     case FFEBLD_opARRAYREF:
2054       {
2055         ffecom_char_args_ (&item, length, ffebld_left (expr));
2056
2057         if (item == error_mark_node || *length == error_mark_node)
2058           {
2059             item = *length = error_mark_node;
2060             break;
2061           }
2062
2063         item = ffecom_arrayref_ (item, expr, 1);
2064       }
2065       break;
2066
2067     case FFEBLD_opSUBSTR:
2068       {
2069         ffebld start;
2070         ffebld end;
2071         ffebld thing = ffebld_right (expr);
2072         tree start_tree;
2073         tree end_tree;
2074         const char *char_name;
2075         ffebld left_symter;
2076         tree array;
2077
2078         assert (ffebld_op (thing) == FFEBLD_opITEM);
2079         start = ffebld_head (thing);
2080         thing = ffebld_trail (thing);
2081         assert (ffebld_trail (thing) == NULL);
2082         end = ffebld_head (thing);
2083
2084         /* Determine name for pretty-printing range-check errors.  */
2085         for (left_symter = ffebld_left (expr);
2086              left_symter && ffebld_op (left_symter) == FFEBLD_opARRAYREF;
2087              left_symter = ffebld_left (left_symter))
2088           ;
2089         if (ffebld_op (left_symter) == FFEBLD_opSYMTER)
2090           char_name = ffesymbol_text (ffebld_symter (left_symter));
2091         else
2092           char_name = "[expr?]";
2093
2094         ffecom_char_args_ (&item, length, ffebld_left (expr));
2095
2096         if (item == error_mark_node || *length == error_mark_node)
2097           {
2098             item = *length = error_mark_node;
2099             break;
2100           }
2101
2102         array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
2103
2104         /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF.  */
2105
2106         if (start == NULL)
2107           {
2108             if (end == NULL)
2109               ;
2110             else
2111               {
2112                 end_tree = ffecom_expr (end);
2113                 if (flag_bounds_check)
2114                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2115                                                       char_name);
2116                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2117                                     end_tree);
2118
2119                 if (end_tree == error_mark_node)
2120                   {
2121                     item = *length = error_mark_node;
2122                     break;
2123                   }
2124
2125                 *length = end_tree;
2126               }
2127           }
2128         else
2129           {
2130             start_tree = ffecom_expr (start);
2131             if (flag_bounds_check)
2132               start_tree = ffecom_subscript_check_ (array, start_tree, 0, 0,
2133                                                     char_name);
2134             start_tree = convert (ffecom_f2c_ftnlen_type_node,
2135                                   start_tree);
2136
2137             if (start_tree == error_mark_node)
2138               {
2139                 item = *length = error_mark_node;
2140                 break;
2141               }
2142
2143             start_tree = ffecom_save_tree (start_tree);
2144
2145             item = ffecom_2 (PLUS_EXPR, TREE_TYPE (item),
2146                              item,
2147                              ffecom_2 (MINUS_EXPR,
2148                                        TREE_TYPE (start_tree),
2149                                        start_tree,
2150                                        ffecom_f2c_ftnlen_one_node));
2151
2152             if (end == NULL)
2153               {
2154                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2155                                     ffecom_f2c_ftnlen_one_node,
2156                                     ffecom_2 (MINUS_EXPR,
2157                                               ffecom_f2c_ftnlen_type_node,
2158                                               *length,
2159                                               start_tree));
2160               }
2161             else
2162               {
2163                 end_tree = ffecom_expr (end);
2164                 if (flag_bounds_check)
2165                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2166                                                       char_name);
2167                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2168                                     end_tree);
2169
2170                 if (end_tree == error_mark_node)
2171                   {
2172                     item = *length = error_mark_node;
2173                     break;
2174                   }
2175
2176                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2177                                     ffecom_f2c_ftnlen_one_node,
2178                                     ffecom_2 (MINUS_EXPR,
2179                                               ffecom_f2c_ftnlen_type_node,
2180                                               end_tree, start_tree));
2181               }
2182           }
2183       }
2184       break;
2185
2186     case FFEBLD_opFUNCREF:
2187       {
2188         ffesymbol s = ffebld_symter (ffebld_left (expr));
2189         tree tempvar;
2190         tree args;
2191         ffetargetCharacterSize size = ffeinfo_size (ffebld_info (expr));
2192         ffecomGfrt ix;
2193
2194         if (size == FFETARGET_charactersizeNONE)
2195           /* ~~Kludge alert!  This should someday be fixed. */
2196           size = 24;
2197
2198         *length = build_int_2 (size, 0);
2199         TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2200
2201         if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
2202             == FFEINFO_whereINTRINSIC)
2203           {
2204             if (size == 1)
2205               {
2206                 /* Invocation of an intrinsic returning CHARACTER*1.  */
2207                 item = ffecom_expr_intrinsic_ (expr, NULL_TREE,
2208                                                NULL, NULL);
2209                 break;
2210               }
2211             ix = ffeintrin_gfrt_direct (ffebld_symter_implementation (ffebld_left (expr)));
2212             assert (ix != FFECOM_gfrt);
2213             item = ffecom_gfrt_tree_ (ix);
2214           }
2215         else
2216           {
2217             ix = FFECOM_gfrt;
2218             item = ffesymbol_hook (s).decl_tree;
2219             if (item == NULL_TREE)
2220               {
2221                 s = ffecom_sym_transform_ (s);
2222                 item = ffesymbol_hook (s).decl_tree;
2223               }
2224             if (item == error_mark_node)
2225               {
2226                 item = *length = error_mark_node;
2227                 break;
2228               }
2229
2230             if (!ffesymbol_hook (s).addr)
2231               item = ffecom_1_fn (item);
2232           }
2233
2234 #ifdef HOHO
2235         tempvar = ffecom_push_tempvar (char_type_node, size, -1, TRUE);
2236 #else
2237         tempvar = ffebld_nonter_hook (expr);
2238         assert (tempvar);
2239 #endif
2240         tempvar = ffecom_1 (ADDR_EXPR,
2241                             build_pointer_type (TREE_TYPE (tempvar)),
2242                             tempvar);
2243
2244         args = build_tree_list (NULL_TREE, tempvar);
2245
2246         if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)       /* Sfunc args by value. */
2247           TREE_CHAIN (args) = ffecom_list_expr (ffebld_right (expr));
2248         else
2249           {
2250             TREE_CHAIN (args) = build_tree_list (NULL_TREE, *length);
2251             if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
2252               {
2253                 TREE_CHAIN (TREE_CHAIN (args))
2254                   = ffecom_arglist_expr_ (ffecom_gfrt_args_ (ix),
2255                                           ffebld_right (expr));
2256               }
2257             else
2258               {
2259                 TREE_CHAIN (TREE_CHAIN (args))
2260                   = ffecom_list_ptr_to_expr (ffebld_right (expr));
2261               }
2262           }
2263
2264         item = ffecom_3s (CALL_EXPR,
2265                           TREE_TYPE (TREE_TYPE (TREE_TYPE (item))),
2266                           item, args, NULL_TREE);
2267         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item,
2268                          tempvar);
2269       }
2270       break;
2271
2272     case FFEBLD_opCONVERT:
2273
2274       ffecom_char_args_ (&item, length, ffebld_left (expr));
2275
2276       if (item == error_mark_node || *length == error_mark_node)
2277         {
2278           item = *length = error_mark_node;
2279           break;
2280         }
2281
2282       if ((ffebld_size_known (ffebld_left (expr))
2283            == FFETARGET_charactersizeNONE)
2284           || (ffebld_size_known (ffebld_left (expr)) < (ffebld_size (expr))))
2285         {                       /* Possible blank-padding needed, copy into
2286                                    temporary. */
2287           tree tempvar;
2288           tree args;
2289           tree newlen;
2290
2291 #ifdef HOHO
2292           tempvar = ffecom_make_tempvar (char_type_node,
2293                                          ffebld_size (expr), -1);
2294 #else
2295           tempvar = ffebld_nonter_hook (expr);
2296           assert (tempvar);
2297 #endif
2298           tempvar = ffecom_1 (ADDR_EXPR,
2299                               build_pointer_type (TREE_TYPE (tempvar)),
2300                               tempvar);
2301
2302           newlen = build_int_2 (ffebld_size (expr), 0);
2303           TREE_TYPE (newlen) = ffecom_f2c_ftnlen_type_node;
2304
2305           args = build_tree_list (NULL_TREE, tempvar);
2306           TREE_CHAIN (args) = build_tree_list (NULL_TREE, item);
2307           TREE_CHAIN (TREE_CHAIN (args)) = build_tree_list (NULL_TREE, newlen);
2308           TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args)))
2309             = build_tree_list (NULL_TREE, *length);
2310
2311           item = ffecom_call_gfrt (FFECOM_gfrtCOPY, args, NULL_TREE);
2312           TREE_SIDE_EFFECTS (item) = 1;
2313           item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), fold (item),
2314                            tempvar);
2315           *length = newlen;
2316         }
2317       else
2318         {                       /* Just truncate the length. */
2319           *length = build_int_2 (ffebld_size (expr), 0);
2320           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2321         }
2322       break;
2323
2324     default:
2325       assert ("bad op for single char arg expr" == NULL);
2326       item = NULL_TREE;
2327       break;
2328     }
2329
2330   *xitem = item;
2331 }
2332 #endif
2333
2334 /* Check the size of the type to be sure it doesn't overflow the
2335    "portable" capacities of the compiler back end.  `dummy' types
2336    can generally overflow the normal sizes as long as the computations
2337    themselves don't overflow.  A particular target of the back end
2338    must still enforce its size requirements, though, and the back
2339    end takes care of this in stor-layout.c.  */
2340
2341 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2342 static tree
2343 ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy)
2344 {
2345   if (TREE_CODE (type) == ERROR_MARK)
2346     return type;
2347
2348   if (TYPE_SIZE (type) == NULL_TREE)
2349     return type;
2350
2351   if (TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST)
2352     return type;
2353
2354   if ((tree_int_cst_sgn (TYPE_SIZE (type)) < 0)
2355       || (!dummy && (((TREE_INT_CST_HIGH (TYPE_SIZE (type)) != 0))
2356                      || TREE_OVERFLOW (TYPE_SIZE (type)))))
2357     {
2358       ffebad_start (FFEBAD_ARRAY_LARGE);
2359       ffebad_string (ffesymbol_text (s));
2360       ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
2361       ffebad_finish ();
2362
2363       return error_mark_node;
2364     }
2365
2366   return type;
2367 }
2368 #endif
2369
2370 /* Builds a length argument (PARM_DECL).  Also wraps type in an array type
2371    where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
2372    known, length_arg if not known (FFETARGET_charactersizeNONE).  */
2373
2374 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2375 static tree
2376 ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s)
2377 {
2378   ffetargetCharacterSize sz = ffesymbol_size (s);
2379   tree highval;
2380   tree tlen;
2381   tree type = *xtype;
2382
2383   if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
2384     tlen = NULL_TREE;           /* A statement function, no length passed. */
2385   else
2386     {
2387       if (ffesymbol_where (s) == FFEINFO_whereDUMMY)
2388         tlen = ffecom_get_invented_identifier ("__g77_length_%s",
2389                                                ffesymbol_text (s));
2390       else
2391         tlen = ffecom_get_invented_identifier ("__g77_%s", "length");
2392       tlen = build_decl (PARM_DECL, tlen, ffecom_f2c_ftnlen_type_node);
2393 #if BUILT_FOR_270
2394       DECL_ARTIFICIAL (tlen) = 1;
2395 #endif
2396     }
2397
2398   if (sz == FFETARGET_charactersizeNONE)
2399     {
2400       assert (tlen != NULL_TREE);
2401       highval = variable_size (tlen);
2402     }
2403   else
2404     {
2405       highval = build_int_2 (sz, 0);
2406       TREE_TYPE (highval) = ffecom_f2c_ftnlen_type_node;
2407     }
2408
2409   type = build_array_type (type,
2410                            build_range_type (ffecom_f2c_ftnlen_type_node,
2411                                              ffecom_f2c_ftnlen_one_node,
2412                                              highval));
2413
2414   *xtype = type;
2415   return tlen;
2416 }
2417
2418 #endif
2419 /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
2420
2421    ffecomConcatList_ catlist;
2422    ffebld expr;  // expr of CHARACTER basictype.
2423    ffetargetCharacterSize max;  // max chars to gather or _...NONE if no max
2424    catlist = ffecom_concat_list_gather_(catlist,expr,max);
2425
2426    Scans expr for character subexpressions, updates and returns catlist
2427    accordingly.  */
2428
2429 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2430 static ffecomConcatList_
2431 ffecom_concat_list_gather_ (ffecomConcatList_ catlist, ffebld expr,
2432                             ffetargetCharacterSize max)
2433 {
2434   ffetargetCharacterSize sz;
2435
2436 recurse:                        /* :::::::::::::::::::: */
2437
2438   if (expr == NULL)
2439     return catlist;
2440
2441   if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen >= max))
2442     return catlist;             /* Don't append any more items. */
2443
2444   switch (ffebld_op (expr))
2445     {
2446     case FFEBLD_opCONTER:
2447     case FFEBLD_opSYMTER:
2448     case FFEBLD_opARRAYREF:
2449     case FFEBLD_opFUNCREF:
2450     case FFEBLD_opSUBSTR:
2451     case FFEBLD_opCONVERT:      /* Callers should strip this off beforehand
2452                                    if they don't need to preserve it. */
2453       if (catlist.count == catlist.max)
2454         {                       /* Make a (larger) list. */
2455           ffebld *newx;
2456           int newmax;
2457
2458           newmax = (catlist.max == 0) ? 8 : catlist.max * 2;
2459           newx = malloc_new_ks (malloc_pool_image (), "catlist",
2460                                 newmax * sizeof (newx[0]));
2461           if (catlist.max != 0)
2462             {
2463               memcpy (newx, catlist.exprs, catlist.max * sizeof (newx[0]));
2464               malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2465                               catlist.max * sizeof (newx[0]));
2466             }
2467           catlist.max = newmax;
2468           catlist.exprs = newx;
2469         }
2470       if ((sz = ffebld_size_known (expr)) != FFETARGET_charactersizeNONE)
2471         catlist.minlen += sz;
2472       else
2473         ++catlist.minlen;       /* Not true for F90; can be 0 length. */
2474       if ((sz = ffebld_size_max (expr)) == FFETARGET_charactersizeNONE)
2475         catlist.maxlen = sz;
2476       else
2477         catlist.maxlen += sz;
2478       if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen > max))
2479         {                       /* This item overlaps (or is beyond) the end
2480                                    of the destination. */
2481           switch (ffebld_op (expr))
2482             {
2483             case FFEBLD_opCONTER:
2484             case FFEBLD_opSYMTER:
2485             case FFEBLD_opARRAYREF:
2486             case FFEBLD_opFUNCREF:
2487             case FFEBLD_opSUBSTR:
2488               /* ~~Do useful truncations here. */
2489               break;
2490
2491             default:
2492               assert ("op changed or inconsistent switches!" == NULL);
2493               break;
2494             }
2495         }
2496       catlist.exprs[catlist.count++] = expr;
2497       return catlist;
2498
2499     case FFEBLD_opPAREN:
2500       expr = ffebld_left (expr);
2501       goto recurse;             /* :::::::::::::::::::: */
2502
2503     case FFEBLD_opCONCATENATE:
2504       catlist = ffecom_concat_list_gather_ (catlist, ffebld_left (expr), max);
2505       expr = ffebld_right (expr);
2506       goto recurse;             /* :::::::::::::::::::: */
2507
2508 #if 0                           /* Breaks passing small actual arg to larger
2509                                    dummy arg of sfunc */
2510     case FFEBLD_opCONVERT:
2511       expr = ffebld_left (expr);
2512       {
2513         ffetargetCharacterSize cmax;
2514
2515         cmax = catlist.len + ffebld_size_known (expr);
2516
2517         if ((max == FFETARGET_charactersizeNONE) || (max > cmax))
2518           max = cmax;
2519       }
2520       goto recurse;             /* :::::::::::::::::::: */
2521 #endif
2522
2523     case FFEBLD_opANY:
2524       return catlist;
2525
2526     default:
2527       assert ("bad op in _gather_" == NULL);
2528       return catlist;
2529     }
2530 }
2531
2532 #endif
2533 /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
2534
2535    ffecomConcatList_ catlist;
2536    ffecom_concat_list_kill_(catlist);
2537
2538    Anything allocated within the list info is deallocated.  */
2539
2540 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2541 static void
2542 ffecom_concat_list_kill_ (ffecomConcatList_ catlist)
2543 {
2544   if (catlist.max != 0)
2545     malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2546                     catlist.max * sizeof (catlist.exprs[0]));
2547 }
2548
2549 #endif
2550 /* Make list of concatenated string exprs.
2551
2552    Returns a flattened list of concatenated subexpressions given a
2553    tree of such expressions.  */
2554
2555 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2556 static ffecomConcatList_
2557 ffecom_concat_list_new_ (ffebld expr, ffetargetCharacterSize max)
2558 {
2559   ffecomConcatList_ catlist;
2560
2561   catlist.maxlen = catlist.minlen = catlist.max = catlist.count = 0;
2562   return ffecom_concat_list_gather_ (catlist, expr, max);
2563 }
2564
2565 #endif
2566
2567 /* Provide some kind of useful info on member of aggregate area,
2568    since current g77/gcc technology does not provide debug info
2569    on these members.  */
2570
2571 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2572 static void
2573 ffecom_debug_kludge_ (tree aggr, const char *aggr_type, ffesymbol member,
2574                       tree member_type UNUSED, ffetargetOffset offset)
2575 {
2576   tree value;
2577   tree decl;
2578   int len;
2579   char *buff;
2580   char space[120];
2581 #if 0
2582   tree type_id;
2583
2584   for (type_id = member_type;
2585        TREE_CODE (type_id) != IDENTIFIER_NODE;
2586        )
2587     {
2588       switch (TREE_CODE (type_id))
2589         {
2590         case INTEGER_TYPE:
2591         case REAL_TYPE:
2592           type_id = TYPE_NAME (type_id);
2593           break;
2594
2595         case ARRAY_TYPE:
2596         case COMPLEX_TYPE:
2597           type_id = TREE_TYPE (type_id);
2598           break;
2599
2600         default:
2601           assert ("no IDENTIFIER_NODE for type!" == NULL);
2602           type_id = error_mark_node;
2603           break;
2604         }
2605     }
2606 #endif
2607
2608   if (ffecom_transform_only_dummies_
2609       || !ffe_is_debug_kludge ())
2610     return;     /* Can't do this yet, maybe later. */
2611
2612   len = 60
2613     + strlen (aggr_type)
2614     + IDENTIFIER_LENGTH (DECL_NAME (aggr));
2615 #if 0
2616     + IDENTIFIER_LENGTH (type_id);
2617 #endif
2618
2619   if (((size_t) len) >= ARRAY_SIZE (space))
2620     buff = malloc_new_ks (malloc_pool_image (), "debug_kludge", len + 1);
2621   else
2622     buff = &space[0];
2623
2624   sprintf (&buff[0], "At (%s) `%s' plus %ld bytes",
2625            aggr_type,
2626            IDENTIFIER_POINTER (DECL_NAME (aggr)),
2627            (long int) offset);
2628
2629   value = build_string (len, buff);
2630   TREE_TYPE (value)
2631     = build_type_variant (build_array_type (char_type_node,
2632                                             build_range_type
2633                                             (integer_type_node,
2634                                              integer_one_node,
2635                                              build_int_2 (strlen (buff), 0))),
2636                           1, 0);
2637   decl = build_decl (VAR_DECL,
2638                      ffecom_get_identifier_ (ffesymbol_text (member)),
2639                      TREE_TYPE (value));
2640   TREE_CONSTANT (decl) = 1;
2641   TREE_STATIC (decl) = 1;
2642   DECL_INITIAL (decl) = error_mark_node;
2643   DECL_IN_SYSTEM_HEADER (decl) = 1;     /* Don't let -Wunused complain. */
2644   decl = start_decl (decl, FALSE);
2645   finish_decl (decl, value, FALSE);
2646
2647   if (buff != &space[0])
2648     malloc_kill_ks (malloc_pool_image (), buff, len + 1);
2649 }
2650 #endif
2651
2652 /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
2653
2654    ffesymbol fn;  // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
2655    int i;  // entry# for this entrypoint (used by master fn)
2656    ffecom_do_entrypoint_(s,i);
2657
2658    Makes a public entry point that calls our private master fn (already
2659    compiled).  */
2660
2661 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2662 static void
2663 ffecom_do_entry_ (ffesymbol fn, int entrynum)
2664 {
2665   ffebld item;
2666   tree type;                    /* Type of function. */
2667   tree multi_retval;            /* Var holding return value (union). */
2668   tree result;                  /* Var holding result. */
2669   ffeinfoBasictype bt;
2670   ffeinfoKindtype kt;
2671   ffeglobal g;
2672   ffeglobalType gt;
2673   bool charfunc;                /* All entry points return same type
2674                                    CHARACTER. */
2675   bool cmplxfunc;               /* Use f2c way of returning COMPLEX. */
2676   bool multi;                   /* Master fn has multiple return types. */
2677   bool altreturning = FALSE;    /* This entry point has alternate returns. */
2678   int yes;
2679   int old_lineno = lineno;
2680   const char *old_input_filename = input_filename;
2681
2682   input_filename = ffesymbol_where_filename (fn);
2683   lineno = ffesymbol_where_filelinenum (fn);
2684
2685   /* c-parse.y indeed does call suspend_momentary and not only ignores the
2686      return value, but also never calls resume_momentary, when starting an
2687      outer function (see "fndef:", "setspecs:", and so on).  So g77 does the
2688      same thing.  It shouldn't be a problem since start_function calls
2689      temporary_allocation, but it might be necessary.  If it causes a problem
2690      here, then maybe there's a bug lurking in gcc.  NOTE: This identical
2691      comment appears twice in thist file.  */
2692
2693   suspend_momentary ();
2694
2695   ffecom_doing_entry_ = TRUE;   /* Don't bother with array dimensions. */
2696
2697   switch (ffecom_primary_entry_kind_)
2698     {
2699     case FFEINFO_kindFUNCTION:
2700
2701       /* Determine actual return type for function. */
2702
2703       gt = FFEGLOBAL_typeFUNC;
2704       bt = ffesymbol_basictype (fn);
2705       kt = ffesymbol_kindtype (fn);
2706       if (bt == FFEINFO_basictypeNONE)
2707         {
2708           ffeimplic_establish_symbol (fn);
2709           if (ffesymbol_funcresult (fn) != NULL)
2710             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
2711           bt = ffesymbol_basictype (fn);
2712           kt = ffesymbol_kindtype (fn);
2713         }
2714
2715       if (bt == FFEINFO_basictypeCHARACTER)
2716         charfunc = TRUE, cmplxfunc = FALSE;
2717       else if ((bt == FFEINFO_basictypeCOMPLEX)
2718                && ffesymbol_is_f2c (fn))
2719         charfunc = FALSE, cmplxfunc = TRUE;
2720       else
2721         charfunc = cmplxfunc = FALSE;
2722
2723       if (charfunc)
2724         type = ffecom_tree_fun_type_void;
2725       else if (ffesymbol_is_f2c (fn))
2726         type = ffecom_tree_fun_type[bt][kt];
2727       else
2728         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
2729
2730       if ((type == NULL_TREE)
2731           || (TREE_TYPE (type) == NULL_TREE))
2732         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
2733
2734       multi = (ffecom_master_bt_ == FFEINFO_basictypeNONE);
2735       break;
2736
2737     case FFEINFO_kindSUBROUTINE:
2738       gt = FFEGLOBAL_typeSUBR;
2739       bt = FFEINFO_basictypeNONE;
2740       kt = FFEINFO_kindtypeNONE;
2741       if (ffecom_is_altreturning_)
2742         {                       /* Am _I_ altreturning? */
2743           for (item = ffesymbol_dummyargs (fn);
2744                item != NULL;
2745                item = ffebld_trail (item))
2746             {
2747               if (ffebld_op (ffebld_head (item)) == FFEBLD_opSTAR)
2748                 {
2749                   altreturning = TRUE;
2750                   break;
2751                 }
2752             }
2753           if (altreturning)
2754             type = ffecom_tree_subr_type;
2755           else
2756             type = ffecom_tree_fun_type_void;
2757         }
2758       else
2759         type = ffecom_tree_fun_type_void;
2760       charfunc = FALSE;
2761       cmplxfunc = FALSE;
2762       multi = FALSE;
2763       break;
2764
2765     default:
2766       assert ("say what??" == NULL);
2767       /* Fall through. */
2768     case FFEINFO_kindANY:
2769       gt = FFEGLOBAL_typeANY;
2770       bt = FFEINFO_basictypeNONE;
2771       kt = FFEINFO_kindtypeNONE;
2772       type = error_mark_node;
2773       charfunc = FALSE;
2774       cmplxfunc = FALSE;
2775       multi = FALSE;
2776       break;
2777     }
2778
2779   /* build_decl uses the current lineno and input_filename to set the decl
2780      source info.  So, I've putzed with ffestd and ffeste code to update that
2781      source info to point to the appropriate statement just before calling
2782      ffecom_do_entrypoint (which calls this fn).  */
2783
2784   start_function (ffecom_get_external_identifier_ (fn),
2785                   type,
2786                   0,            /* nested/inline */
2787                   1);           /* TREE_PUBLIC */
2788
2789   if (((g = ffesymbol_global (fn)) != NULL)
2790       && ((ffeglobal_type (g) == gt)
2791           || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
2792     {
2793       ffeglobal_set_hook (g, current_function_decl);
2794     }
2795
2796   /* Reset args in master arg list so they get retransitioned. */
2797
2798   for (item = ffecom_master_arglist_;
2799        item != NULL;
2800        item = ffebld_trail (item))
2801     {
2802       ffebld arg;
2803       ffesymbol s;
2804
2805       arg = ffebld_head (item);
2806       if (ffebld_op (arg) != FFEBLD_opSYMTER)
2807         continue;               /* Alternate return or some such thing. */
2808       s = ffebld_symter (arg);
2809       ffesymbol_hook (s).decl_tree = NULL_TREE;
2810       ffesymbol_hook (s).length_tree = NULL_TREE;
2811     }
2812
2813   /* Build dummy arg list for this entry point. */
2814
2815   yes = suspend_momentary ();
2816
2817   if (charfunc || cmplxfunc)
2818     {                           /* Prepend arg for where result goes. */
2819       tree type;
2820       tree length;
2821
2822       if (charfunc)
2823         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
2824       else
2825         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
2826
2827       result = ffecom_get_invented_identifier ("__g77_%s", "result");
2828
2829       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
2830
2831       if (charfunc)
2832         length = ffecom_char_enhance_arg_ (&type, fn);
2833       else
2834         length = NULL_TREE;     /* Not ref'd if !charfunc. */
2835
2836       type = build_pointer_type (type);
2837       result = build_decl (PARM_DECL, result, type);
2838
2839       push_parm_decl (result);
2840       ffecom_func_result_ = result;
2841
2842       if (charfunc)
2843         {
2844           push_parm_decl (length);
2845           ffecom_func_length_ = length;
2846         }
2847     }
2848   else
2849     result = DECL_RESULT (current_function_decl);
2850
2851   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn), FALSE);
2852
2853   resume_momentary (yes);
2854
2855   store_parm_decls (0);
2856
2857   ffecom_start_compstmt ();
2858   /* Disallow temp vars at this level.  */
2859   current_binding_level->prep_state = 2;
2860
2861   /* Make local var to hold return type for multi-type master fn. */
2862
2863   if (multi)
2864     {
2865       yes = suspend_momentary ();
2866
2867       multi_retval = ffecom_get_invented_identifier ("__g77_%s",
2868                                                      "multi_retval");
2869       multi_retval = build_decl (VAR_DECL, multi_retval,
2870                                  ffecom_multi_type_node_);
2871       multi_retval = start_decl (multi_retval, FALSE);
2872       finish_decl (multi_retval, NULL_TREE, FALSE);
2873
2874       resume_momentary (yes);
2875     }
2876   else
2877     multi_retval = NULL_TREE;   /* Not actually ref'd if !multi. */
2878
2879   /* Here we emit the actual code for the entry point. */
2880
2881   {
2882     ffebld list;
2883     ffebld arg;
2884     ffesymbol s;
2885     tree arglist = NULL_TREE;
2886     tree *plist = &arglist;
2887     tree prepend;
2888     tree call;
2889     tree actarg;
2890     tree master_fn;
2891
2892     /* Prepare actual arg list based on master arg list. */
2893
2894     for (list = ffecom_master_arglist_;
2895          list != NULL;
2896          list = ffebld_trail (list))
2897       {
2898         arg = ffebld_head (list);
2899         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2900           continue;
2901         s = ffebld_symter (arg);
2902         if (ffesymbol_hook (s).decl_tree == NULL_TREE
2903             || ffesymbol_hook (s).decl_tree == error_mark_node)
2904           actarg = null_pointer_node;   /* We don't have this arg. */
2905         else
2906           actarg = ffesymbol_hook (s).decl_tree;
2907         *plist = build_tree_list (NULL_TREE, actarg);
2908         plist = &TREE_CHAIN (*plist);
2909       }
2910
2911     /* This code appends the length arguments for character
2912        variables/arrays.  */
2913
2914     for (list = ffecom_master_arglist_;
2915          list != NULL;
2916          list = ffebld_trail (list))
2917       {
2918         arg = ffebld_head (list);
2919         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2920           continue;
2921         s = ffebld_symter (arg);
2922         if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
2923           continue;             /* Only looking for CHARACTER arguments. */
2924         if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
2925           continue;             /* Only looking for variables and arrays. */
2926         if (ffesymbol_hook (s).length_tree == NULL_TREE
2927             || ffesymbol_hook (s).length_tree == error_mark_node)
2928           actarg = ffecom_f2c_ftnlen_zero_node; /* We don't have this arg. */
2929         else
2930           actarg = ffesymbol_hook (s).length_tree;
2931         *plist = build_tree_list (NULL_TREE, actarg);
2932         plist = &TREE_CHAIN (*plist);
2933       }
2934
2935     /* Prepend character-value return info to actual arg list. */
2936
2937     if (charfunc)
2938       {
2939         prepend = build_tree_list (NULL_TREE, ffecom_func_result_);
2940         TREE_CHAIN (prepend)
2941           = build_tree_list (NULL_TREE, ffecom_func_length_);
2942         TREE_CHAIN (TREE_CHAIN (prepend)) = arglist;
2943         arglist = prepend;
2944       }
2945
2946     /* Prepend multi-type return value to actual arg list. */
2947
2948     if (multi)
2949       {
2950         prepend
2951           = build_tree_list (NULL_TREE,
2952                              ffecom_1 (ADDR_EXPR,
2953                               build_pointer_type (TREE_TYPE (multi_retval)),
2954                                        multi_retval));
2955         TREE_CHAIN (prepend) = arglist;
2956         arglist = prepend;
2957       }
2958
2959     /* Prepend my entry-point number to the actual arg list. */
2960
2961     prepend = build_tree_list (NULL_TREE, build_int_2 (entrynum, 0));
2962     TREE_CHAIN (prepend) = arglist;
2963     arglist = prepend;
2964
2965     /* Build the call to the master function. */
2966
2967     master_fn = ffecom_1_fn (ffecom_previous_function_decl_);
2968     call = ffecom_3s (CALL_EXPR,
2969                       TREE_TYPE (TREE_TYPE (TREE_TYPE (master_fn))),
2970                       master_fn, arglist, NULL_TREE);
2971
2972     /* Decide whether the master function is a function or subroutine, and
2973        handle the return value for my entry point. */
2974
2975     if (charfunc || ((ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
2976                      && !altreturning))
2977       {
2978         expand_expr_stmt (call);
2979         expand_null_return ();
2980       }
2981     else if (multi && cmplxfunc)
2982       {
2983         expand_expr_stmt (call);
2984         result
2985           = ffecom_1 (INDIRECT_REF,
2986                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2987                       result);
2988         result = ffecom_modify (NULL_TREE, result,
2989                                 ffecom_2 (COMPONENT_REF, TREE_TYPE (result),
2990                                           multi_retval,
2991                                           ffecom_multi_fields_[bt][kt]));
2992         expand_expr_stmt (result);
2993         expand_null_return ();
2994       }
2995     else if (multi)
2996       {
2997         expand_expr_stmt (call);
2998         result
2999           = ffecom_modify (NULL_TREE, result,
3000                            convert (TREE_TYPE (result),
3001                                     ffecom_2 (COMPONENT_REF,
3002                                               ffecom_tree_type[bt][kt],
3003                                               multi_retval,
3004                                               ffecom_multi_fields_[bt][kt])));
3005         expand_return (result);
3006       }
3007     else if (cmplxfunc)
3008       {
3009         result
3010           = ffecom_1 (INDIRECT_REF,
3011                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
3012                       result);
3013         result = ffecom_modify (NULL_TREE, result, call);
3014         expand_expr_stmt (result);
3015         expand_null_return ();
3016       }
3017     else
3018       {
3019         result = ffecom_modify (NULL_TREE,
3020                                 result,
3021                                 convert (TREE_TYPE (result),
3022                                          call));
3023         expand_return (result);
3024       }
3025
3026     clear_momentary ();
3027   }
3028
3029   ffecom_end_compstmt ();
3030
3031   finish_function (0);
3032
3033   lineno = old_lineno;
3034   input_filename = old_input_filename;
3035
3036   ffecom_doing_entry_ = FALSE;
3037 }
3038
3039 #endif
3040 /* Transform expr into gcc tree with possible destination
3041
3042    Recursive descent on expr while making corresponding tree nodes and
3043    attaching type info and such.  If destination supplied and compatible
3044    with temporary that would be made in certain cases, temporary isn't
3045    made, destination used instead, and dest_used flag set TRUE.  */
3046
3047 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3048 static tree
3049 ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
3050               bool *dest_used, bool assignp, bool widenp)
3051 {
3052   tree item;
3053   tree list;
3054   tree args;
3055   ffeinfoBasictype bt;
3056   ffeinfoKindtype kt;
3057   tree t;
3058   tree dt;                      /* decl_tree for an ffesymbol. */
3059   tree tree_type, tree_type_x;
3060   tree left, right;
3061   ffesymbol s;
3062   enum tree_code code;
3063
3064   assert (expr != NULL);
3065
3066   if (dest_used != NULL)
3067     *dest_used = FALSE;
3068
3069   bt = ffeinfo_basictype (ffebld_info (expr));
3070   kt = ffeinfo_kindtype (ffebld_info (expr));
3071   tree_type = ffecom_tree_type[bt][kt];
3072
3073   /* Widen integral arithmetic as desired while preserving signedness.  */
3074   tree_type_x = NULL_TREE;
3075   if (widenp && tree_type
3076       && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
3077       && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
3078     tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
3079
3080   switch (ffebld_op (expr))
3081     {
3082     case FFEBLD_opACCTER:
3083       {
3084         ffebitCount i;
3085         ffebit bits = ffebld_accter_bits (expr);
3086         ffetargetOffset source_offset = 0;
3087         ffetargetOffset dest_offset = ffebld_accter_pad (expr);
3088         tree purpose;
3089
3090         assert (dest_offset == 0
3091                 || (bt == FFEINFO_basictypeCHARACTER
3092                     && kt == FFEINFO_kindtypeCHARACTER1));
3093
3094         list = item = NULL;
3095         for (;;)
3096           {
3097             ffebldConstantUnion cu;
3098             ffebitCount length;
3099             bool value;
3100             ffebldConstantArray ca = ffebld_accter (expr);
3101
3102             ffebit_test (bits, source_offset, &value, &length);
3103             if (length == 0)
3104               break;
3105
3106             if (value)
3107               {
3108                 for (i = 0; i < length; ++i)
3109                   {
3110                     cu = ffebld_constantarray_get (ca, bt, kt,
3111                                                    source_offset + i);
3112
3113                     t = ffecom_constantunion (&cu, bt, kt, tree_type);
3114
3115                     if (i == 0
3116                         && dest_offset != 0)
3117                       purpose = build_int_2 (dest_offset, 0);
3118                     else
3119                       purpose = NULL_TREE;
3120
3121                     if (list == NULL_TREE)
3122                       list = item = build_tree_list (purpose, t);
3123                     else
3124                       {
3125                         TREE_CHAIN (item) = build_tree_list (purpose, t);
3126                         item = TREE_CHAIN (item);
3127                       }
3128                   }
3129               }
3130             source_offset += length;
3131             dest_offset += length;
3132           }
3133       }
3134
3135       item = build_int_2 ((ffebld_accter_size (expr)
3136                            + ffebld_accter_pad (expr)) - 1, 0);
3137       ffebit_kill (ffebld_accter_bits (expr));
3138       TREE_TYPE (item) = ffecom_integer_type_node;
3139       item
3140         = build_array_type
3141           (tree_type,
3142            build_range_type (ffecom_integer_type_node,
3143                              ffecom_integer_zero_node,
3144                              item));
3145       list = build (CONSTRUCTOR, item, NULL_TREE, list);
3146       TREE_CONSTANT (list) = 1;
3147       TREE_STATIC (list) = 1;
3148       return list;
3149
3150     case FFEBLD_opARRTER:
3151       {
3152         ffetargetOffset i;
3153
3154         list = NULL_TREE;
3155         if (ffebld_arrter_pad (expr) == 0)
3156           item = NULL_TREE;
3157         else
3158           {
3159             assert (bt == FFEINFO_basictypeCHARACTER
3160                     && kt == FFEINFO_kindtypeCHARACTER1);
3161
3162             /* Becomes PURPOSE first time through loop.  */
3163             item = build_int_2 (ffebld_arrter_pad (expr), 0);
3164           }
3165
3166         for (i = 0; i < ffebld_arrter_size (expr); ++i)
3167           {
3168             ffebldConstantUnion cu
3169             = ffebld_constantarray_get (ffebld_arrter (expr), bt, kt, i);
3170
3171             t = ffecom_constantunion (&cu, bt, kt, tree_type);
3172
3173             if (list == NULL_TREE)
3174               /* Assume item is PURPOSE first time through loop.  */
3175               list = item = build_tree_list (item, t);
3176             else
3177               {
3178                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
3179                 item = TREE_CHAIN (item);
3180               }
3181           }
3182       }
3183
3184       item = build_int_2 ((ffebld_arrter_size (expr)
3185                           + ffebld_arrter_pad (expr)) - 1, 0);
3186       TREE_TYPE (item) = ffecom_integer_type_node;
3187       item
3188         = build_array_type
3189           (tree_type,
3190            build_range_type (ffecom_integer_type_node,
3191                              ffecom_integer_zero_node,
3192                              item));
3193       list = build (CONSTRUCTOR, item, NULL_TREE, list);
3194       TREE_CONSTANT (list) = 1;
3195       TREE_STATIC (list) = 1;
3196       return list;
3197
3198     case FFEBLD_opCONTER:
3199       assert (ffebld_conter_pad (expr) == 0);
3200       item
3201         = ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr)),
3202                                 bt, kt, tree_type);
3203       return item;
3204
3205     case FFEBLD_opSYMTER:
3206       if ((ffebld_symter_generic (expr) != FFEINTRIN_genNONE)
3207           || (ffebld_symter_specific (expr) != FFEINTRIN_specNONE))
3208         return ffecom_ptr_to_expr (expr);       /* Same as %REF(intrinsic). */
3209       s = ffebld_symter (expr);
3210       t = ffesymbol_hook (s).decl_tree;
3211
3212       if (assignp)
3213         {                       /* ASSIGN'ed-label expr. */
3214           if (ffe_is_ugly_assign ())
3215             {
3216               /* User explicitly wants ASSIGN'ed variables to be at the same
3217                  memory address as the variables when used in non-ASSIGN
3218                  contexts.  That can make old, arcane, non-standard code
3219                  work, but don't try to do it when a pointer wouldn't fit
3220                  in the normal variable (take other approach, and warn,
3221                  instead).  */
3222
3223               if (t == NULL_TREE)
3224                 {
3225                   s = ffecom_sym_transform_ (s);
3226                   t = ffesymbol_hook (s).decl_tree;
3227                   assert (t != NULL_TREE);
3228                 }
3229
3230               if (t == error_mark_node)
3231                 return t;
3232
3233               if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t)))
3234                   >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
3235                 {
3236                   if (ffesymbol_hook (s).addr)
3237                     t = ffecom_1 (INDIRECT_REF,
3238                                   TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3239                   return t;
3240                 }
3241
3242               if (ffesymbol_hook (s).assign_tree == NULL_TREE)
3243                 {
3244                   ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling",
3245                                     FFEBAD_severityWARNING);
3246                   ffebad_string (ffesymbol_text (s));
3247                   ffebad_here (0, ffesymbol_where_line (s),
3248                                ffesymbol_where_column (s));
3249                   ffebad_finish ();
3250                 }
3251             }
3252
3253           /* Don't use the normal variable's tree for ASSIGN, though mark
3254              it as in the system header (housekeeping).  Use an explicit,
3255              specially created sibling that is known to be wide enough
3256              to hold pointers to labels.  */
3257
3258           if (t != NULL_TREE
3259               && TREE_CODE (t) == VAR_DECL)
3260             DECL_IN_SYSTEM_HEADER (t) = 1;      /* Don't let -Wunused complain. */
3261
3262           t = ffesymbol_hook (s).assign_tree;
3263           if (t == NULL_TREE)
3264             {
3265               s = ffecom_sym_transform_assign_ (s);
3266               t = ffesymbol_hook (s).assign_tree;
3267               assert (t != NULL_TREE);
3268             }
3269         }
3270       else
3271         {
3272           if (t == NULL_TREE)
3273             {
3274               s = ffecom_sym_transform_ (s);
3275               t = ffesymbol_hook (s).decl_tree;
3276               assert (t != NULL_TREE);
3277             }
3278           if (ffesymbol_hook (s).addr)
3279             t = ffecom_1 (INDIRECT_REF,
3280                           TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3281         }
3282       return t;
3283
3284     case FFEBLD_opARRAYREF:
3285       return ffecom_arrayref_ (NULL_TREE, expr, 0);
3286
3287     case FFEBLD_opUPLUS:
3288       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3289       return ffecom_1 (NOP_EXPR, tree_type, left);
3290
3291     case FFEBLD_opPAREN:
3292       /* ~~~Make sure Fortran rules respected here */
3293       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3294       return ffecom_1 (NOP_EXPR, tree_type, left);
3295
3296     case FFEBLD_opUMINUS:
3297       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3298       if (tree_type_x)
3299         {
3300           tree_type = tree_type_x;
3301           left = convert (tree_type, left);
3302         }
3303       return ffecom_1 (NEGATE_EXPR, tree_type, left);
3304
3305     case FFEBLD_opADD:
3306       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3307       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3308       if (tree_type_x)
3309         {
3310           tree_type = tree_type_x;
3311           left = convert (tree_type, left);
3312           right = convert (tree_type, right);
3313         }
3314       return ffecom_2 (PLUS_EXPR, tree_type, left, right);
3315
3316     case FFEBLD_opSUBTRACT:
3317       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3318       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3319       if (tree_type_x)
3320         {
3321           tree_type = tree_type_x;
3322           left = convert (tree_type, left);
3323           right = convert (tree_type, right);
3324         }
3325       return ffecom_2 (MINUS_EXPR, tree_type, left, right);
3326
3327     case FFEBLD_opMULTIPLY:
3328       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3329       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3330       if (tree_type_x)
3331         {
3332           tree_type = tree_type_x;
3333           left = convert (tree_type, left);
3334           right = convert (tree_type, right);
3335         }
3336       return ffecom_2 (MULT_EXPR, tree_type, left, right);
3337
3338     case FFEBLD_opDIVIDE:
3339       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3340       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3341       if (tree_type_x)
3342         {
3343           tree_type = tree_type_x;
3344           left = convert (tree_type, left);
3345           right = convert (tree_type, right);
3346         }
3347       return ffecom_tree_divide_ (tree_type, left, right,
3348                                   dest_tree, dest, dest_used,
3349                                   ffebld_nonter_hook (expr));
3350
3351     case FFEBLD_opPOWER:
3352       {
3353         ffebld left = ffebld_left (expr);
3354         ffebld right = ffebld_right (expr);
3355         ffecomGfrt code;
3356         ffeinfoKindtype rtkt;
3357         ffeinfoKindtype ltkt;
3358
3359         switch (ffeinfo_basictype (ffebld_info (right)))
3360           {
3361           case FFEINFO_basictypeINTEGER:
3362             if (1 || optimize)
3363               {
3364                 item = ffecom_expr_power_integer_ (expr);
3365                 if (item != NULL_TREE)
3366                   return item;
3367               }
3368
3369             rtkt = FFEINFO_kindtypeINTEGER1;
3370             switch (ffeinfo_basictype (ffebld_info (left)))
3371               {
3372               case FFEINFO_basictypeINTEGER:
3373                 if ((ffeinfo_kindtype (ffebld_info (left))
3374                     == FFEINFO_kindtypeINTEGER4)
3375                     || (ffeinfo_kindtype (ffebld_info (right))
3376                         == FFEINFO_kindtypeINTEGER4))
3377                   {
3378                     code = FFECOM_gfrtPOW_QQ;
3379                     ltkt = FFEINFO_kindtypeINTEGER4;
3380                     rtkt = FFEINFO_kindtypeINTEGER4;
3381                   }
3382                 else
3383                   {
3384                     code = FFECOM_gfrtPOW_II;
3385                     ltkt = FFEINFO_kindtypeINTEGER1;
3386                   }
3387                 break;
3388
3389               case FFEINFO_basictypeREAL:
3390                 if (ffeinfo_kindtype (ffebld_info (left))
3391                     == FFEINFO_kindtypeREAL1)
3392                   {
3393                     code = FFECOM_gfrtPOW_RI;
3394                     ltkt = FFEINFO_kindtypeREAL1;
3395                   }
3396                 else
3397                   {
3398                     code = FFECOM_gfrtPOW_DI;
3399                     ltkt = FFEINFO_kindtypeREAL2;
3400                   }
3401                 break;
3402
3403               case FFEINFO_basictypeCOMPLEX:
3404                 if (ffeinfo_kindtype (ffebld_info (left))
3405                     == FFEINFO_kindtypeREAL1)
3406                   {
3407                     code = FFECOM_gfrtPOW_CI;   /* Overlapping result okay. */
3408                     ltkt = FFEINFO_kindtypeREAL1;
3409                   }
3410                 else
3411                   {
3412                     code = FFECOM_gfrtPOW_ZI;   /* Overlapping result okay. */
3413                     ltkt = FFEINFO_kindtypeREAL2;
3414                   }
3415                 break;
3416
3417               default:
3418                 assert ("bad pow_*i" == NULL);
3419                 code = FFECOM_gfrtPOW_CI;       /* Overlapping result okay. */
3420                 ltkt = FFEINFO_kindtypeREAL1;
3421                 break;
3422               }
3423             if (ffeinfo_kindtype (ffebld_info (left)) != ltkt)
3424               left = ffeexpr_convert (left, NULL, NULL,
3425                                       ffeinfo_basictype (ffebld_info (left)),
3426                                       ltkt, 0,
3427                                       FFETARGET_charactersizeNONE,
3428                                       FFEEXPR_contextLET);
3429             if (ffeinfo_kindtype (ffebld_info (right)) != rtkt)
3430               right = ffeexpr_convert (right, NULL, NULL,
3431                                        FFEINFO_basictypeINTEGER,
3432                                        rtkt, 0,
3433                                        FFETARGET_charactersizeNONE,
3434                                        FFEEXPR_contextLET);
3435             break;
3436
3437           case FFEINFO_basictypeREAL:
3438             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3439               left = ffeexpr_convert (left, NULL, NULL, FFEINFO_basictypeREAL,
3440                                       FFEINFO_kindtypeREALDOUBLE, 0,
3441                                       FFETARGET_charactersizeNONE,
3442                                       FFEEXPR_contextLET);
3443             if (ffeinfo_kindtype (ffebld_info (right))
3444                 == FFEINFO_kindtypeREAL1)
3445               right = ffeexpr_convert (right, NULL, NULL,
3446                                        FFEINFO_basictypeREAL,
3447                                        FFEINFO_kindtypeREALDOUBLE, 0,
3448                                        FFETARGET_charactersizeNONE,
3449                                        FFEEXPR_contextLET);
3450             code = FFECOM_gfrtPOW_DD;
3451             break;
3452
3453           case FFEINFO_basictypeCOMPLEX:
3454             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3455               left = ffeexpr_convert (left, NULL, NULL,
3456                                       FFEINFO_basictypeCOMPLEX,
3457                                       FFEINFO_kindtypeREALDOUBLE, 0,
3458                                       FFETARGET_charactersizeNONE,
3459                                       FFEEXPR_contextLET);
3460             if (ffeinfo_kindtype (ffebld_info (right))
3461                 == FFEINFO_kindtypeREAL1)
3462               right = ffeexpr_convert (right, NULL, NULL,
3463                                        FFEINFO_basictypeCOMPLEX,
3464                                        FFEINFO_kindtypeREALDOUBLE, 0,
3465                                        FFETARGET_charactersizeNONE,
3466                                        FFEEXPR_contextLET);
3467             code = FFECOM_gfrtPOW_ZZ;   /* Overlapping result okay. */
3468             break;
3469
3470           default:
3471             assert ("bad pow_x*" == NULL);
3472             code = FFECOM_gfrtPOW_II;
3473             break;
3474           }
3475         return ffecom_call_binop_ (ffecom_gfrt_tree_ (code),
3476                                    ffecom_gfrt_kindtype (code),
3477                                    (ffe_is_f2c_library ()
3478                                     && ffecom_gfrt_complex_[code]),
3479                                    tree_type, left, right,
3480                                    dest_tree, dest, dest_used,
3481                                    NULL_TREE, FALSE,
3482                                    ffebld_nonter_hook (expr));
3483       }
3484
3485     case FFEBLD_opNOT:
3486       switch (bt)
3487         {
3488         case FFEINFO_basictypeLOGICAL:
3489           item = ffecom_truth_value_invert (ffecom_expr (ffebld_left (expr)));
3490           return convert (tree_type, item);
3491
3492         case FFEINFO_basictypeINTEGER:
3493           return ffecom_1 (BIT_NOT_EXPR, tree_type,
3494                            ffecom_expr (ffebld_left (expr)));
3495
3496         default:
3497           assert ("NOT bad basictype" == NULL);
3498           /* Fall through. */
3499         case FFEINFO_basictypeANY:
3500           return error_mark_node;
3501         }
3502       break;
3503
3504     case FFEBLD_opFUNCREF:
3505       assert (ffeinfo_basictype (ffebld_info (expr))
3506               != FFEINFO_basictypeCHARACTER);
3507       /* Fall through.   */
3508     case FFEBLD_opSUBRREF:
3509       if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
3510           == FFEINFO_whereINTRINSIC)
3511         {                       /* Invocation of an intrinsic. */
3512           item = ffecom_expr_intrinsic_ (expr, dest_tree, dest,
3513                                          dest_used);
3514           return item;
3515         }
3516       s = ffebld_symter (ffebld_left (expr));
3517       dt = ffesymbol_hook (s).decl_tree;
3518       if (dt == NULL_TREE)
3519         {
3520           s = ffecom_sym_transform_ (s);
3521           dt = ffesymbol_hook (s).decl_tree;
3522         }
3523       if (dt == error_mark_node)
3524         return dt;
3525
3526       if (ffesymbol_hook (s).addr)
3527         item = dt;
3528       else
3529         item = ffecom_1_fn (dt);
3530
3531       if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
3532         args = ffecom_list_expr (ffebld_right (expr));
3533       else
3534         args = ffecom_list_ptr_to_expr (ffebld_right (expr));
3535
3536       if (args == error_mark_node)
3537         return error_mark_node;
3538
3539       item = ffecom_call_ (item, kt,
3540                            ffesymbol_is_f2c (s)
3541                            && (bt == FFEINFO_basictypeCOMPLEX)
3542                            && (ffesymbol_where (s)
3543                                != FFEINFO_whereCONSTANT),
3544                            tree_type,
3545                            args,
3546                            dest_tree, dest, dest_used,
3547                            error_mark_node, FALSE,
3548                            ffebld_nonter_hook (expr));
3549       TREE_SIDE_EFFECTS (item) = 1;
3550       return item;
3551
3552     case FFEBLD_opAND:
3553       switch (bt)
3554         {
3555         case FFEINFO_basictypeLOGICAL:
3556           item
3557             = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3558                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3559                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3560           return convert (tree_type, item);
3561
3562         case FFEINFO_basictypeINTEGER:
3563           return ffecom_2 (BIT_AND_EXPR, tree_type,
3564                            ffecom_expr (ffebld_left (expr)),
3565                            ffecom_expr (ffebld_right (expr)));
3566
3567         default:
3568           assert ("AND bad basictype" == NULL);
3569           /* Fall through. */
3570         case FFEINFO_basictypeANY:
3571           return error_mark_node;
3572         }
3573       break;
3574
3575     case FFEBLD_opOR:
3576       switch (bt)
3577         {
3578         case FFEINFO_basictypeLOGICAL:
3579           item
3580             = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
3581                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3582                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3583           return convert (tree_type, item);
3584
3585         case FFEINFO_basictypeINTEGER:
3586           return ffecom_2 (BIT_IOR_EXPR, tree_type,
3587                            ffecom_expr (ffebld_left (expr)),
3588                            ffecom_expr (ffebld_right (expr)));
3589
3590         default:
3591           assert ("OR bad basictype" == NULL);
3592           /* Fall through. */
3593         case FFEINFO_basictypeANY:
3594           return error_mark_node;
3595         }
3596       break;
3597
3598     case FFEBLD_opXOR:
3599     case FFEBLD_opNEQV:
3600       switch (bt)
3601         {
3602         case FFEINFO_basictypeLOGICAL:
3603           item
3604             = ffecom_2 (NE_EXPR, integer_type_node,
3605                         ffecom_expr (ffebld_left (expr)),
3606                         ffecom_expr (ffebld_right (expr)));
3607           return convert (tree_type, ffecom_truth_value (item));
3608
3609         case FFEINFO_basictypeINTEGER:
3610           return ffecom_2 (BIT_XOR_EXPR, tree_type,
3611                            ffecom_expr (ffebld_left (expr)),
3612                            ffecom_expr (ffebld_right (expr)));
3613
3614         default:
3615           assert ("XOR/NEQV bad basictype" == NULL);
3616           /* Fall through. */
3617         case FFEINFO_basictypeANY:
3618           return error_mark_node;
3619         }
3620       break;
3621
3622     case FFEBLD_opEQV:
3623       switch (bt)
3624         {
3625         case FFEINFO_basictypeLOGICAL:
3626           item
3627             = ffecom_2 (EQ_EXPR, integer_type_node,
3628                         ffecom_expr (ffebld_left (expr)),
3629                         ffecom_expr (ffebld_right (expr)));
3630           return convert (tree_type, ffecom_truth_value (item));
3631
3632         case FFEINFO_basictypeINTEGER:
3633           return
3634             ffecom_1 (BIT_NOT_EXPR, tree_type,
3635                       ffecom_2 (BIT_XOR_EXPR, tree_type,
3636                                 ffecom_expr (ffebld_left (expr)),
3637                                 ffecom_expr (ffebld_right (expr))));
3638
3639         default:
3640           assert ("EQV bad basictype" == NULL);
3641           /* Fall through. */
3642         case FFEINFO_basictypeANY:
3643           return error_mark_node;
3644         }
3645       break;
3646
3647     case FFEBLD_opCONVERT:
3648       if (ffebld_op (ffebld_left (expr)) == FFEBLD_opANY)
3649         return error_mark_node;
3650
3651       switch (bt)
3652         {
3653         case FFEINFO_basictypeLOGICAL:
3654         case FFEINFO_basictypeINTEGER:
3655         case FFEINFO_basictypeREAL:
3656           return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3657
3658         case FFEINFO_basictypeCOMPLEX:
3659           switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3660             {
3661             case FFEINFO_basictypeINTEGER:
3662             case FFEINFO_basictypeLOGICAL:
3663             case FFEINFO_basictypeREAL:
3664               item = ffecom_expr (ffebld_left (expr));
3665               if (item == error_mark_node)
3666                 return error_mark_node;
3667               /* convert() takes care of converting to the subtype first,
3668                  at least in gcc-2.7.2. */
3669               item = convert (tree_type, item);
3670               return item;
3671
3672             case FFEINFO_basictypeCOMPLEX:
3673               return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3674
3675             default:
3676               assert ("CONVERT COMPLEX bad basictype" == NULL);
3677               /* Fall through. */
3678             case FFEINFO_basictypeANY:
3679               return error_mark_node;
3680             }
3681           break;
3682
3683         default:
3684           assert ("CONVERT bad basictype" == NULL);
3685           /* Fall through. */
3686         case FFEINFO_basictypeANY:
3687           return error_mark_node;
3688         }
3689       break;
3690
3691     case FFEBLD_opLT:
3692       code = LT_EXPR;
3693       goto relational;          /* :::::::::::::::::::: */
3694
3695     case FFEBLD_opLE:
3696       code = LE_EXPR;
3697       goto relational;          /* :::::::::::::::::::: */
3698
3699     case FFEBLD_opEQ:
3700       code = EQ_EXPR;
3701       goto relational;          /* :::::::::::::::::::: */
3702
3703     case FFEBLD_opNE:
3704       code = NE_EXPR;
3705       goto relational;          /* :::::::::::::::::::: */
3706
3707     case FFEBLD_opGT:
3708       code = GT_EXPR;
3709       goto relational;          /* :::::::::::::::::::: */
3710
3711     case FFEBLD_opGE:
3712       code = GE_EXPR;
3713
3714     relational:         /* :::::::::::::::::::: */
3715       switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3716         {
3717         case FFEINFO_basictypeLOGICAL:
3718         case FFEINFO_basictypeINTEGER:
3719         case FFEINFO_basictypeREAL:
3720           item = ffecom_2 (code, integer_type_node,
3721                            ffecom_expr (ffebld_left (expr)),
3722                            ffecom_expr (ffebld_right (expr)));
3723           return convert (tree_type, item);
3724
3725         case FFEINFO_basictypeCOMPLEX:
3726           assert (code == EQ_EXPR || code == NE_EXPR);
3727           {
3728             tree real_type;
3729             tree arg1 = ffecom_expr (ffebld_left (expr));
3730             tree arg2 = ffecom_expr (ffebld_right (expr));
3731
3732             if (arg1 == error_mark_node || arg2 == error_mark_node)
3733               return error_mark_node;
3734
3735             arg1 = ffecom_save_tree (arg1);
3736             arg2 = ffecom_save_tree (arg2);
3737
3738             if (TREE_CODE (TREE_TYPE (arg1)) == COMPLEX_TYPE)
3739               {
3740                 real_type = TREE_TYPE (TREE_TYPE (arg1));
3741                 assert (real_type == TREE_TYPE (TREE_TYPE (arg2)));
3742               }
3743             else
3744               {
3745                 real_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg1)));
3746                 assert (real_type == TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg2))));
3747               }
3748
3749             item
3750               = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3751                           ffecom_2 (EQ_EXPR, integer_type_node,
3752                                   ffecom_1 (REALPART_EXPR, real_type, arg1),
3753                                  ffecom_1 (REALPART_EXPR, real_type, arg2)),
3754                           ffecom_2 (EQ_EXPR, integer_type_node,
3755                                   ffecom_1 (IMAGPART_EXPR, real_type, arg1),
3756                                     ffecom_1 (IMAGPART_EXPR, real_type,
3757                                               arg2)));
3758             if (code == EQ_EXPR)
3759               item = ffecom_truth_value (item);
3760             else
3761               item = ffecom_truth_value_invert (item);
3762             return convert (tree_type, item);
3763           }
3764
3765         case FFEINFO_basictypeCHARACTER:
3766           {
3767             ffebld left = ffebld_left (expr);
3768             ffebld right = ffebld_right (expr);
3769             tree left_tree;
3770             tree right_tree;
3771             tree left_length;
3772             tree right_length;
3773
3774             /* f2c run-time functions do the implicit blank-padding for us,
3775                so we don't usually have to implement blank-padding ourselves.
3776                (The exception is when we pass an argument to a separately
3777                compiled statement function -- if we know the arg is not the
3778                same length as the dummy, we must truncate or extend it.  If
3779                we "inline" statement functions, that necessity goes away as
3780                well.)
3781
3782                Strip off the CONVERT operators that blank-pad.  (Truncation by
3783                CONVERT shouldn't happen here, but it can happen in
3784                assignments.) */
3785
3786             while (ffebld_op (left) == FFEBLD_opCONVERT)
3787               left = ffebld_left (left);
3788             while (ffebld_op (right) == FFEBLD_opCONVERT)
3789               right = ffebld_left (right);
3790
3791             left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
3792             right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
3793
3794             if (left_tree == error_mark_node || left_length == error_mark_node
3795                 || right_tree == error_mark_node
3796                 || right_length == error_mark_node)
3797               return error_mark_node;
3798
3799             if ((ffebld_size_known (left) == 1)
3800                 && (ffebld_size_known (right) == 1))
3801               {
3802                 left_tree
3803                   = ffecom_1 (INDIRECT_REF,
3804                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3805                               left_tree);
3806                 right_tree
3807                   = ffecom_1 (INDIRECT_REF,
3808                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3809                               right_tree);
3810
3811                 item
3812                   = ffecom_2 (code, integer_type_node,
3813                               ffecom_2 (ARRAY_REF,
3814                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3815                                         left_tree,
3816                                         integer_one_node),
3817                               ffecom_2 (ARRAY_REF,
3818                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3819                                         right_tree,
3820                                         integer_one_node));
3821               }
3822             else
3823               {
3824                 item = build_tree_list (NULL_TREE, left_tree);
3825                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, right_tree);
3826                 TREE_CHAIN (TREE_CHAIN (item)) = build_tree_list (NULL_TREE,
3827                                                                left_length);
3828                 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
3829                   = build_tree_list (NULL_TREE, right_length);
3830                 item = ffecom_call_gfrt (FFECOM_gfrtCMP, item, NULL_TREE);
3831                 item = ffecom_2 (code, integer_type_node,
3832                                  item,
3833                                  convert (TREE_TYPE (item),
3834                                           integer_zero_node));
3835               }
3836             item = convert (tree_type, item);
3837           }
3838
3839           return item;
3840
3841         default:
3842           assert ("relational bad basictype" == NULL);
3843           /* Fall through. */
3844         case FFEINFO_basictypeANY:
3845           return error_mark_node;
3846         }
3847       break;
3848
3849     case FFEBLD_opPERCENT_LOC:
3850       item = ffecom_arg_ptr_to_expr (ffebld_left (expr), &list);
3851       return convert (tree_type, item);
3852
3853     case FFEBLD_opITEM:
3854     case FFEBLD_opSTAR:
3855     case FFEBLD_opBOUNDS:
3856     case FFEBLD_opREPEAT:
3857     case FFEBLD_opLABTER:
3858     case FFEBLD_opLABTOK:
3859     case FFEBLD_opIMPDO:
3860     case FFEBLD_opCONCATENATE:
3861     case FFEBLD_opSUBSTR:
3862     default:
3863       assert ("bad op" == NULL);
3864       /* Fall through. */
3865     case FFEBLD_opANY:
3866       return error_mark_node;
3867     }
3868
3869 #if 1
3870   assert ("didn't think anything got here anymore!!" == NULL);
3871 #else
3872   switch (ffebld_arity (expr))
3873     {
3874     case 2:
3875       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3876       TREE_OPERAND (item, 1) = ffecom_expr (ffebld_right (expr));
3877       if (TREE_OPERAND (item, 0) == error_mark_node
3878           || TREE_OPERAND (item, 1) == error_mark_node)
3879         return error_mark_node;
3880       break;
3881
3882     case 1:
3883       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3884       if (TREE_OPERAND (item, 0) == error_mark_node)
3885         return error_mark_node;
3886       break;
3887
3888     default:
3889       break;
3890     }
3891
3892   return fold (item);
3893 #endif
3894 }
3895
3896 #endif
3897 /* Returns the tree that does the intrinsic invocation.
3898
3899    Note: this function applies only to intrinsics returning
3900    CHARACTER*1 or non-CHARACTER results, and to intrinsic
3901    subroutines.  */
3902
3903 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3904 static tree
3905 ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
3906                         ffebld dest, bool *dest_used)
3907 {
3908   tree expr_tree;
3909   tree saved_expr1;             /* For those who need it. */
3910   tree saved_expr2;             /* For those who need it. */
3911   ffeinfoBasictype bt;
3912   ffeinfoKindtype kt;
3913   tree tree_type;
3914   tree arg1_type;
3915   tree real_type;               /* REAL type corresponding to COMPLEX. */
3916   tree tempvar;
3917   ffebld list = ffebld_right (expr);    /* List of (some) args. */
3918   ffebld arg1;                  /* For handy reference. */
3919   ffebld arg2;
3920   ffebld arg3;
3921   ffeintrinImp codegen_imp;
3922   ffecomGfrt gfrt;
3923
3924   assert (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER);
3925
3926   if (dest_used != NULL)
3927     *dest_used = FALSE;
3928
3929   bt = ffeinfo_basictype (ffebld_info (expr));
3930   kt = ffeinfo_kindtype (ffebld_info (expr));
3931   tree_type = ffecom_tree_type[bt][kt];
3932
3933   if (list != NULL)
3934     {
3935       arg1 = ffebld_head (list);
3936       if (arg1 != NULL && ffebld_op (arg1) == FFEBLD_opANY)
3937         return error_mark_node;
3938       if ((list = ffebld_trail (list)) != NULL)
3939         {
3940           arg2 = ffebld_head (list);
3941           if (arg2 != NULL && ffebld_op (arg2) == FFEBLD_opANY)
3942             return error_mark_node;
3943           if ((list = ffebld_trail (list)) != NULL)
3944             {
3945               arg3 = ffebld_head (list);
3946               if (arg3 != NULL && ffebld_op (arg3) == FFEBLD_opANY)
3947                 return error_mark_node;
3948             }
3949           else
3950             arg3 = NULL;
3951         }
3952       else
3953         arg2 = arg3 = NULL;
3954     }
3955   else
3956     arg1 = arg2 = arg3 = NULL;
3957
3958   /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
3959      args.  This is used by the MAX/MIN expansions. */
3960
3961   if (arg1 != NULL)
3962     arg1_type = ffecom_tree_type
3963       [ffeinfo_basictype (ffebld_info (arg1))]
3964       [ffeinfo_kindtype (ffebld_info (arg1))];
3965   else
3966     arg1_type = NULL_TREE;      /* Really not needed, but might catch bugs
3967                                    here. */
3968
3969   /* There are several ways for each of the cases in the following switch
3970      statements to exit (from simplest to use to most complicated):
3971
3972      break;  (when expr_tree == NULL)
3973
3974      A standard call is made to the specific intrinsic just as if it had been
3975      passed in as a dummy procedure and called as any old procedure.  This
3976      method can produce slower code but in some cases it's the easiest way for
3977      now.  However, if a (presumably faster) direct call is available,
3978      that is used, so this is the easiest way in many more cases now.
3979
3980      gfrt = FFECOM_gfrtWHATEVER;
3981      break;
3982
3983      gfrt contains the gfrt index of a library function to call, passing the
3984      argument(s) by value rather than by reference.  Used when a more
3985      careful choice of library function is needed than that provided
3986      by the vanilla `break;'.
3987
3988      return expr_tree;
3989
3990      The expr_tree has been completely set up and is ready to be returned
3991      as is.  No further actions are taken.  Use this when the tree is not
3992      in the simple form for one of the arity_n labels.   */
3993
3994   /* For info on how the switch statement cases were written, see the files
3995      enclosed in comments below the switch statement. */
3996
3997   codegen_imp = ffebld_symter_implementation (ffebld_left (expr));
3998   gfrt = ffeintrin_gfrt_direct (codegen_imp);
3999   if (gfrt == FFECOM_gfrt)
4000     gfrt = ffeintrin_gfrt_indirect (codegen_imp);
4001
4002   switch (codegen_imp)
4003     {
4004     case FFEINTRIN_impABS:
4005     case FFEINTRIN_impCABS:
4006     case FFEINTRIN_impCDABS:
4007     case FFEINTRIN_impDABS:
4008     case FFEINTRIN_impIABS:
4009       if (ffeinfo_basictype (ffebld_info (arg1))
4010           == FFEINFO_basictypeCOMPLEX)
4011         {
4012           if (kt == FFEINFO_kindtypeREAL1)
4013             gfrt = FFECOM_gfrtCABS;
4014           else if (kt == FFEINFO_kindtypeREAL2)
4015             gfrt = FFECOM_gfrtCDABS;
4016           break;
4017         }
4018       return ffecom_1 (ABS_EXPR, tree_type,
4019                        convert (tree_type, ffecom_expr (arg1)));
4020
4021     case FFEINTRIN_impACOS:
4022     case FFEINTRIN_impDACOS:
4023       break;
4024
4025     case FFEINTRIN_impAIMAG:
4026     case FFEINTRIN_impDIMAG:
4027     case FFEINTRIN_impIMAGPART:
4028       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
4029         arg1_type = TREE_TYPE (arg1_type);
4030       else
4031         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
4032
4033       return
4034         convert (tree_type,
4035                  ffecom_1 (IMAGPART_EXPR, arg1_type,
4036                            ffecom_expr (arg1)));
4037
4038     case FFEINTRIN_impAINT:
4039     case FFEINTRIN_impDINT:
4040 #if 0
4041       /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg.  */
4042       return ffecom_1 (FIX_TRUNC_EXPR, tree_type, ffecom_expr (arg1));
4043 #else /* in the meantime, must use floor to avoid range problems with ints */
4044       /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
4045       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4046       return
4047         convert (tree_type,
4048                  ffecom_3 (COND_EXPR, double_type_node,
4049                            ffecom_truth_value
4050                            (ffecom_2 (GE_EXPR, integer_type_node,
4051                                       saved_expr1,
4052                                       convert (arg1_type,
4053                                                ffecom_float_zero_))),
4054                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4055                                              build_tree_list (NULL_TREE,
4056                                                   convert (double_type_node,
4057                                                            saved_expr1)),
4058                                              NULL_TREE),
4059                            ffecom_1 (NEGATE_EXPR, double_type_node,
4060                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4061                                                  build_tree_list (NULL_TREE,
4062                                                   convert (double_type_node,
4063                                                       ffecom_1 (NEGATE_EXPR,
4064                                                                 arg1_type,
4065                                                                saved_expr1))),
4066                                                        NULL_TREE)
4067                                      ))
4068                  );
4069 #endif
4070
4071     case FFEINTRIN_impANINT:
4072     case FFEINTRIN_impDNINT:
4073 #if 0                           /* This way of doing it won't handle real
4074                                    numbers of large magnitudes. */
4075       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4076       expr_tree = convert (tree_type,
4077                            convert (integer_type_node,
4078                                     ffecom_3 (COND_EXPR, tree_type,
4079                                               ffecom_truth_value
4080                                               (ffecom_2 (GE_EXPR,
4081                                                          integer_type_node,
4082                                                          saved_expr1,
4083                                                        ffecom_float_zero_)),
4084                                               ffecom_2 (PLUS_EXPR,
4085                                                         tree_type,
4086                                                         saved_expr1,
4087                                                         ffecom_float_half_),
4088                                               ffecom_2 (MINUS_EXPR,
4089                                                         tree_type,
4090                                                         saved_expr1,
4091                                                      ffecom_float_half_))));
4092       return expr_tree;
4093 #else /* So we instead call floor. */
4094       /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
4095       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4096       return
4097         convert (tree_type,
4098                  ffecom_3 (COND_EXPR, double_type_node,
4099                            ffecom_truth_value
4100                            (ffecom_2 (GE_EXPR, integer_type_node,
4101                                       saved_expr1,
4102                                       convert (arg1_type,
4103                                                ffecom_float_zero_))),
4104                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4105                                              build_tree_list (NULL_TREE,
4106                                                   convert (double_type_node,
4107                                                            ffecom_2 (PLUS_EXPR,
4108                                                                      arg1_type,
4109                                                                      saved_expr1,
4110                                                                      convert (arg1_type,
4111                                                                               ffecom_float_half_)))),
4112                                              NULL_TREE),
4113                            ffecom_1 (NEGATE_EXPR, double_type_node,
4114                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4115                                                        build_tree_list (NULL_TREE,
4116                                                                         convert (double_type_node,
4117                                                                                  ffecom_2 (MINUS_EXPR,
4118                                                                                            arg1_type,
4119                                                                                            convert (arg1_type,
4120                                                                                                     ffecom_float_half_),
4121                                                                                            saved_expr1))),
4122                                                        NULL_TREE))
4123                            )
4124                  );
4125 #endif
4126
4127     case FFEINTRIN_impASIN:
4128     case FFEINTRIN_impDASIN:
4129     case FFEINTRIN_impATAN:
4130     case FFEINTRIN_impDATAN:
4131     case FFEINTRIN_impATAN2:
4132     case FFEINTRIN_impDATAN2:
4133       break;
4134
4135     case FFEINTRIN_impCHAR:
4136     case FFEINTRIN_impACHAR:
4137 #ifdef HOHO
4138       tempvar = ffecom_make_tempvar (char_type_node, 1, -1);
4139 #else
4140       tempvar = ffebld_nonter_hook (expr);
4141       assert (tempvar);
4142 #endif
4143       {
4144         tree tmv = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar)));
4145
4146         expr_tree = ffecom_modify (tmv,
4147                                    ffecom_2 (ARRAY_REF, tmv, tempvar,
4148                                              integer_one_node),
4149                                    convert (tmv, ffecom_expr (arg1)));
4150       }
4151       expr_tree = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar),
4152                             expr_tree,
4153                             tempvar);
4154       expr_tree = ffecom_1 (ADDR_EXPR,
4155                             build_pointer_type (TREE_TYPE (expr_tree)),
4156                             expr_tree);
4157       return expr_tree;
4158
4159     case FFEINTRIN_impCMPLX:
4160     case FFEINTRIN_impDCMPLX:
4161       if (arg2 == NULL)
4162         return
4163           convert (tree_type, ffecom_expr (arg1));
4164
4165       real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4166       return
4167         ffecom_2 (COMPLEX_EXPR, tree_type,
4168                   convert (real_type, ffecom_expr (arg1)),
4169                   convert (real_type,
4170                            ffecom_expr (arg2)));
4171
4172     case FFEINTRIN_impCOMPLEX:
4173       return
4174         ffecom_2 (COMPLEX_EXPR, tree_type,
4175                   ffecom_expr (arg1),
4176                   ffecom_expr (arg2));
4177
4178     case FFEINTRIN_impCONJG:
4179     case FFEINTRIN_impDCONJG:
4180       {
4181         tree arg1_tree;
4182
4183         real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4184         arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4185         return
4186           ffecom_2 (COMPLEX_EXPR, tree_type,
4187                     ffecom_1 (REALPART_EXPR, real_type, arg1_tree),
4188                     ffecom_1 (NEGATE_EXPR, real_type,
4189                               ffecom_1 (IMAGPART_EXPR, real_type, arg1_tree)));
4190       }
4191
4192     case FFEINTRIN_impCOS:
4193     case FFEINTRIN_impCCOS:
4194     case FFEINTRIN_impCDCOS:
4195     case FFEINTRIN_impDCOS:
4196       if (bt == FFEINFO_basictypeCOMPLEX)
4197         {
4198           if (kt == FFEINFO_kindtypeREAL1)
4199             gfrt = FFECOM_gfrtCCOS;     /* Overlapping result okay. */
4200           else if (kt == FFEINFO_kindtypeREAL2)
4201             gfrt = FFECOM_gfrtCDCOS;    /* Overlapping result okay. */
4202         }
4203       break;
4204
4205     case FFEINTRIN_impCOSH:
4206     case FFEINTRIN_impDCOSH:
4207       break;
4208
4209     case FFEINTRIN_impDBLE:
4210     case FFEINTRIN_impDFLOAT:
4211     case FFEINTRIN_impDREAL:
4212     case FFEINTRIN_impFLOAT:
4213     case FFEINTRIN_impIDINT:
4214     case FFEINTRIN_impIFIX:
4215     case FFEINTRIN_impINT2:
4216     case FFEINTRIN_impINT8:
4217     case FFEINTRIN_impINT:
4218     case FFEINTRIN_impLONG:
4219     case FFEINTRIN_impREAL:
4220     case FFEINTRIN_impSHORT:
4221     case FFEINTRIN_impSNGL:
4222       return convert (tree_type, ffecom_expr (arg1));
4223
4224     case FFEINTRIN_impDIM:
4225     case FFEINTRIN_impDDIM:
4226     case FFEINTRIN_impIDIM:
4227       saved_expr1 = ffecom_save_tree (convert (tree_type,
4228                                                ffecom_expr (arg1)));
4229       saved_expr2 = ffecom_save_tree (convert (tree_type,
4230                                                ffecom_expr (arg2)));
4231       return
4232         ffecom_3 (COND_EXPR, tree_type,
4233                   ffecom_truth_value
4234                   (ffecom_2 (GT_EXPR, integer_type_node,
4235                              saved_expr1,
4236                              saved_expr2)),
4237                   ffecom_2 (MINUS_EXPR, tree_type,
4238                             saved_expr1,
4239                             saved_expr2),
4240                   convert (tree_type, ffecom_float_zero_));
4241
4242     case FFEINTRIN_impDPROD:
4243       return
4244         ffecom_2 (MULT_EXPR, tree_type,
4245                   convert (tree_type, ffecom_expr (arg1)),
4246                   convert (tree_type, ffecom_expr (arg2)));
4247
4248     case FFEINTRIN_impEXP:
4249     case FFEINTRIN_impCDEXP:
4250     case FFEINTRIN_impCEXP:
4251     case FFEINTRIN_impDEXP:
4252       if (bt == FFEINFO_basictypeCOMPLEX)
4253         {
4254           if (kt == FFEINFO_kindtypeREAL1)
4255             gfrt = FFECOM_gfrtCEXP;     /* Overlapping result okay. */
4256           else if (kt == FFEINFO_kindtypeREAL2)
4257             gfrt = FFECOM_gfrtCDEXP;    /* Overlapping result okay. */
4258         }
4259       break;
4260
4261     case FFEINTRIN_impICHAR:
4262     case FFEINTRIN_impIACHAR:
4263 #if 0                           /* The simple approach. */
4264       ffecom_char_args_ (&expr_tree, &saved_expr1 /* Ignored */ , arg1);
4265       expr_tree
4266         = ffecom_1 (INDIRECT_REF,
4267                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4268                     expr_tree);
4269       expr_tree
4270         = ffecom_2 (ARRAY_REF,
4271                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4272                     expr_tree,
4273                     integer_one_node);
4274       return convert (tree_type, expr_tree);
4275 #else /* The more interesting (and more optimal) approach. */
4276       expr_tree = ffecom_intrinsic_ichar_ (tree_type, arg1, &saved_expr1);
4277       expr_tree = ffecom_3 (COND_EXPR, tree_type,
4278                             saved_expr1,
4279                             expr_tree,
4280                             convert (tree_type, integer_zero_node));
4281       return expr_tree;
4282 #endif
4283
4284     case FFEINTRIN_impINDEX:
4285       break;
4286
4287     case FFEINTRIN_impLEN:
4288 #if 0
4289       break;                                    /* The simple approach. */
4290 #else
4291       return ffecom_intrinsic_len_ (arg1);      /* The more optimal approach. */
4292 #endif
4293
4294     case FFEINTRIN_impLGE:
4295     case FFEINTRIN_impLGT:
4296     case FFEINTRIN_impLLE:
4297     case FFEINTRIN_impLLT:
4298       break;
4299
4300     case FFEINTRIN_impLOG:
4301     case FFEINTRIN_impALOG:
4302     case FFEINTRIN_impCDLOG:
4303     case FFEINTRIN_impCLOG:
4304     case FFEINTRIN_impDLOG:
4305       if (bt == FFEINFO_basictypeCOMPLEX)
4306         {
4307           if (kt == FFEINFO_kindtypeREAL1)
4308             gfrt = FFECOM_gfrtCLOG;     /* Overlapping result okay. */
4309           else if (kt == FFEINFO_kindtypeREAL2)
4310             gfrt = FFECOM_gfrtCDLOG;    /* Overlapping result okay. */
4311         }
4312       break;
4313
4314     case FFEINTRIN_impLOG10:
4315     case FFEINTRIN_impALOG10:
4316     case FFEINTRIN_impDLOG10:
4317       if (gfrt != FFECOM_gfrt)
4318         break;  /* Already picked one, stick with it. */
4319
4320       if (kt == FFEINFO_kindtypeREAL1)
4321         gfrt = FFECOM_gfrtALOG10;
4322       else if (kt == FFEINFO_kindtypeREAL2)
4323         gfrt = FFECOM_gfrtDLOG10;
4324       break;
4325
4326     case FFEINTRIN_impMAX:
4327     case FFEINTRIN_impAMAX0:
4328     case FFEINTRIN_impAMAX1:
4329     case FFEINTRIN_impDMAX1:
4330     case FFEINTRIN_impMAX0:
4331     case FFEINTRIN_impMAX1:
4332       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4333         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4334       else
4335         arg1_type = tree_type;
4336       expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4337                             convert (arg1_type, ffecom_expr (arg1)),
4338                             convert (arg1_type, ffecom_expr (arg2)));
4339       for (; list != NULL; list = ffebld_trail (list))
4340         {
4341           if ((ffebld_head (list) == NULL)
4342               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4343             continue;
4344           expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4345                                 expr_tree,
4346                                 convert (arg1_type,
4347                                          ffecom_expr (ffebld_head (list))));
4348         }
4349       return convert (tree_type, expr_tree);
4350
4351     case FFEINTRIN_impMIN:
4352     case FFEINTRIN_impAMIN0:
4353     case FFEINTRIN_impAMIN1:
4354     case FFEINTRIN_impDMIN1:
4355     case FFEINTRIN_impMIN0:
4356     case FFEINTRIN_impMIN1:
4357       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4358         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4359       else
4360         arg1_type = tree_type;
4361       expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4362                             convert (arg1_type, ffecom_expr (arg1)),
4363                             convert (arg1_type, ffecom_expr (arg2)));
4364       for (; list != NULL; list = ffebld_trail (list))
4365         {
4366           if ((ffebld_head (list) == NULL)
4367               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4368             continue;
4369           expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4370                                 expr_tree,
4371                                 convert (arg1_type,
4372                                          ffecom_expr (ffebld_head (list))));
4373         }
4374       return convert (tree_type, expr_tree);
4375
4376     case FFEINTRIN_impMOD:
4377     case FFEINTRIN_impAMOD:
4378     case FFEINTRIN_impDMOD:
4379       if (bt != FFEINFO_basictypeREAL)
4380         return ffecom_2 (TRUNC_MOD_EXPR, tree_type,
4381                          convert (tree_type, ffecom_expr (arg1)),
4382                          convert (tree_type, ffecom_expr (arg2)));
4383
4384       if (kt == FFEINFO_kindtypeREAL1)
4385         gfrt = FFECOM_gfrtAMOD;
4386       else if (kt == FFEINFO_kindtypeREAL2)
4387         gfrt = FFECOM_gfrtDMOD;
4388       break;
4389
4390     case FFEINTRIN_impNINT:
4391     case FFEINTRIN_impIDNINT:
4392 #if 0
4393       /* ~~Ideally FIX_ROUND_EXPR would be implemented, but it ain't yet.  */
4394       return ffecom_1 (FIX_ROUND_EXPR, tree_type, ffecom_expr (arg1));
4395 #else
4396       /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
4397       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4398       return
4399         convert (ffecom_integer_type_node,
4400                  ffecom_3 (COND_EXPR, arg1_type,
4401                            ffecom_truth_value
4402                            (ffecom_2 (GE_EXPR, integer_type_node,
4403                                       saved_expr1,
4404                                       convert (arg1_type,
4405                                                ffecom_float_zero_))),
4406                            ffecom_2 (PLUS_EXPR, arg1_type,
4407                                      saved_expr1,
4408                                      convert (arg1_type,
4409                                               ffecom_float_half_)),
4410                            ffecom_2 (MINUS_EXPR, arg1_type,
4411                                      saved_expr1,
4412                                      convert (arg1_type,
4413                                               ffecom_float_half_))));
4414 #endif
4415
4416     case FFEINTRIN_impSIGN:
4417     case FFEINTRIN_impDSIGN:
4418     case FFEINTRIN_impISIGN:
4419       {
4420         tree arg2_tree = ffecom_expr (arg2);
4421
4422         saved_expr1
4423           = ffecom_save_tree
4424           (ffecom_1 (ABS_EXPR, tree_type,
4425                      convert (tree_type,
4426                               ffecom_expr (arg1))));
4427         expr_tree
4428           = ffecom_3 (COND_EXPR, tree_type,
4429                       ffecom_truth_value
4430                       (ffecom_2 (GE_EXPR, integer_type_node,
4431                                  arg2_tree,
4432                                  convert (TREE_TYPE (arg2_tree),
4433                                           integer_zero_node))),
4434                       saved_expr1,
4435                       ffecom_1 (NEGATE_EXPR, tree_type, saved_expr1));
4436         /* Make sure SAVE_EXPRs get referenced early enough. */
4437         expr_tree
4438           = ffecom_2 (COMPOUND_EXPR, tree_type,
4439                       convert (void_type_node, saved_expr1),
4440                       expr_tree);
4441       }
4442       return expr_tree;
4443
4444     case FFEINTRIN_impSIN:
4445     case FFEINTRIN_impCDSIN:
4446     case FFEINTRIN_impCSIN:
4447     case FFEINTRIN_impDSIN:
4448       if (bt == FFEINFO_basictypeCOMPLEX)
4449         {
4450           if (kt == FFEINFO_kindtypeREAL1)
4451             gfrt = FFECOM_gfrtCSIN;     /* Overlapping result okay. */
4452           else if (kt == FFEINFO_kindtypeREAL2)
4453             gfrt = FFECOM_gfrtCDSIN;    /* Overlapping result okay. */
4454         }
4455       break;
4456
4457     case FFEINTRIN_impSINH:
4458     case FFEINTRIN_impDSINH:
4459       break;
4460
4461     case FFEINTRIN_impSQRT:
4462     case FFEINTRIN_impCDSQRT:
4463     case FFEINTRIN_impCSQRT:
4464     case FFEINTRIN_impDSQRT:
4465       if (bt == FFEINFO_basictypeCOMPLEX)
4466         {
4467           if (kt == FFEINFO_kindtypeREAL1)
4468             gfrt = FFECOM_gfrtCSQRT;    /* Overlapping result okay. */
4469           else if (kt == FFEINFO_kindtypeREAL2)
4470             gfrt = FFECOM_gfrtCDSQRT;   /* Overlapping result okay. */
4471         }
4472       break;
4473
4474     case FFEINTRIN_impTAN:
4475     case FFEINTRIN_impDTAN:
4476     case FFEINTRIN_impTANH:
4477     case FFEINTRIN_impDTANH:
4478       break;
4479
4480     case FFEINTRIN_impREALPART:
4481       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
4482         arg1_type = TREE_TYPE (arg1_type);
4483       else
4484         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
4485
4486       return
4487         convert (tree_type,
4488                  ffecom_1 (REALPART_EXPR, arg1_type,
4489                            ffecom_expr (arg1)));
4490
4491     case FFEINTRIN_impIAND:
4492     case FFEINTRIN_impAND:
4493       return ffecom_2 (BIT_AND_EXPR, tree_type,
4494                        convert (tree_type,
4495                                 ffecom_expr (arg1)),
4496                        convert (tree_type,
4497                                 ffecom_expr (arg2)));
4498
4499     case FFEINTRIN_impIOR:
4500     case FFEINTRIN_impOR:
4501       return ffecom_2 (BIT_IOR_EXPR, tree_type,
4502                        convert (tree_type,
4503                                 ffecom_expr (arg1)),
4504                        convert (tree_type,
4505                                 ffecom_expr (arg2)));
4506
4507     case FFEINTRIN_impIEOR:
4508     case FFEINTRIN_impXOR:
4509       return ffecom_2 (BIT_XOR_EXPR, tree_type,
4510                        convert (tree_type,
4511                                 ffecom_expr (arg1)),
4512                        convert (tree_type,
4513                                 ffecom_expr (arg2)));
4514
4515     case FFEINTRIN_impLSHIFT:
4516       return ffecom_2 (LSHIFT_EXPR, tree_type,
4517                        ffecom_expr (arg1),
4518                        convert (integer_type_node,
4519                                 ffecom_expr (arg2)));
4520
4521     case FFEINTRIN_impRSHIFT:
4522       return ffecom_2 (RSHIFT_EXPR, tree_type,
4523                        ffecom_expr (arg1),
4524                        convert (integer_type_node,
4525                                 ffecom_expr (arg2)));
4526
4527     case FFEINTRIN_impNOT:
4528       return ffecom_1 (BIT_NOT_EXPR, tree_type, ffecom_expr (arg1));
4529
4530     case FFEINTRIN_impBIT_SIZE:
4531       return convert (tree_type, TYPE_SIZE (arg1_type));
4532
4533     case FFEINTRIN_impBTEST:
4534       {
4535         ffetargetLogical1 true;
4536         ffetargetLogical1 false;
4537         tree true_tree;
4538         tree false_tree;
4539
4540         ffetarget_logical1 (&true, TRUE);
4541         ffetarget_logical1 (&false, FALSE);
4542         if (true == 1)
4543           true_tree = convert (tree_type, integer_one_node);
4544         else
4545           true_tree = convert (tree_type, build_int_2 (true, 0));
4546         if (false == 0)
4547           false_tree = convert (tree_type, integer_zero_node);
4548         else
4549           false_tree = convert (tree_type, build_int_2 (false, 0));
4550
4551         return
4552           ffecom_3 (COND_EXPR, tree_type,
4553                     ffecom_truth_value
4554                     (ffecom_2 (EQ_EXPR, integer_type_node,
4555                                ffecom_2 (BIT_AND_EXPR, arg1_type,
4556                                          ffecom_expr (arg1),
4557                                          ffecom_2 (LSHIFT_EXPR, arg1_type,
4558                                                    convert (arg1_type,
4559                                                           integer_one_node),
4560                                                    convert (integer_type_node,
4561                                                             ffecom_expr (arg2)))),
4562                                convert (arg1_type,
4563                                         integer_zero_node))),
4564                     false_tree,
4565                     true_tree);
4566       }
4567
4568     case FFEINTRIN_impIBCLR:
4569       return
4570         ffecom_2 (BIT_AND_EXPR, tree_type,
4571                   ffecom_expr (arg1),
4572                   ffecom_1 (BIT_NOT_EXPR, tree_type,
4573                             ffecom_2 (LSHIFT_EXPR, tree_type,
4574                                       convert (tree_type,
4575                                                integer_one_node),
4576                                       convert (integer_type_node,
4577                                                ffecom_expr (arg2)))));
4578
4579     case FFEINTRIN_impIBITS:
4580       {
4581         tree arg3_tree = ffecom_save_tree (convert (integer_type_node,
4582                                                     ffecom_expr (arg3)));
4583         tree uns_type
4584         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4585
4586         expr_tree
4587           = ffecom_2 (BIT_AND_EXPR, tree_type,
4588                       ffecom_2 (RSHIFT_EXPR, tree_type,
4589                                 ffecom_expr (arg1),
4590                                 convert (integer_type_node,
4591                                          ffecom_expr (arg2))),
4592                       convert (tree_type,
4593                                ffecom_2 (RSHIFT_EXPR, uns_type,
4594                                          ffecom_1 (BIT_NOT_EXPR,
4595                                                    uns_type,
4596                                                    convert (uns_type,
4597                                                         integer_zero_node)),
4598                                          ffecom_2 (MINUS_EXPR,
4599                                                    integer_type_node,
4600                                                    TYPE_SIZE (uns_type),
4601                                                    arg3_tree))));
4602 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4603         expr_tree
4604           = ffecom_3 (COND_EXPR, tree_type,
4605                       ffecom_truth_value
4606                       (ffecom_2 (NE_EXPR, integer_type_node,
4607                                  arg3_tree,
4608                                  integer_zero_node)),
4609                       expr_tree,
4610                       convert (tree_type, integer_zero_node));
4611 #endif
4612       }
4613       return expr_tree;
4614
4615     case FFEINTRIN_impIBSET:
4616       return
4617         ffecom_2 (BIT_IOR_EXPR, tree_type,
4618                   ffecom_expr (arg1),
4619                   ffecom_2 (LSHIFT_EXPR, tree_type,
4620                             convert (tree_type, integer_one_node),
4621                             convert (integer_type_node,
4622                                      ffecom_expr (arg2))));
4623
4624     case FFEINTRIN_impISHFT:
4625       {
4626         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4627         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4628                                                     ffecom_expr (arg2)));
4629         tree uns_type
4630         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4631
4632         expr_tree
4633           = ffecom_3 (COND_EXPR, tree_type,
4634                       ffecom_truth_value
4635                       (ffecom_2 (GE_EXPR, integer_type_node,
4636                                  arg2_tree,
4637                                  integer_zero_node)),
4638                       ffecom_2 (LSHIFT_EXPR, tree_type,
4639                                 arg1_tree,
4640                                 arg2_tree),
4641                       convert (tree_type,
4642                                ffecom_2 (RSHIFT_EXPR, uns_type,
4643                                          convert (uns_type, arg1_tree),
4644                                          ffecom_1 (NEGATE_EXPR,
4645                                                    integer_type_node,
4646                                                    arg2_tree))));
4647 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4648         expr_tree
4649           = ffecom_3 (COND_EXPR, tree_type,
4650                       ffecom_truth_value
4651                       (ffecom_2 (NE_EXPR, integer_type_node,
4652                                  arg2_tree,
4653                                  TYPE_SIZE (uns_type))),
4654                       expr_tree,
4655                       convert (tree_type, integer_zero_node));
4656 #endif
4657         /* Make sure SAVE_EXPRs get referenced early enough. */
4658         expr_tree
4659           = ffecom_2 (COMPOUND_EXPR, tree_type,
4660                       convert (void_type_node, arg1_tree),
4661                       ffecom_2 (COMPOUND_EXPR, tree_type,
4662                                 convert (void_type_node, arg2_tree),
4663                                 expr_tree));
4664       }
4665       return expr_tree;
4666
4667     case FFEINTRIN_impISHFTC:
4668       {
4669         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4670         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4671                                                     ffecom_expr (arg2)));
4672         tree arg3_tree = (arg3 == NULL) ? TYPE_SIZE (tree_type)
4673         : ffecom_save_tree (convert (integer_type_node, ffecom_expr (arg3)));
4674         tree shift_neg;
4675         tree shift_pos;
4676         tree mask_arg1;
4677         tree masked_arg1;
4678         tree uns_type
4679         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4680
4681         mask_arg1
4682           = ffecom_2 (LSHIFT_EXPR, tree_type,
4683                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4684                                 convert (tree_type, integer_zero_node)),
4685                       arg3_tree);
4686 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4687         mask_arg1
4688           = ffecom_3 (COND_EXPR, tree_type,
4689                       ffecom_truth_value
4690                       (ffecom_2 (NE_EXPR, integer_type_node,
4691                                  arg3_tree,
4692                                  TYPE_SIZE (uns_type))),
4693                       mask_arg1,
4694                       convert (tree_type, integer_zero_node));
4695 #endif
4696         mask_arg1 = ffecom_save_tree (mask_arg1);
4697         masked_arg1
4698           = ffecom_2 (BIT_AND_EXPR, tree_type,
4699                       arg1_tree,
4700                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4701                                 mask_arg1));
4702         masked_arg1 = ffecom_save_tree (masked_arg1);
4703         shift_neg
4704           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4705                       convert (tree_type,
4706                                ffecom_2 (RSHIFT_EXPR, uns_type,
4707                                          convert (uns_type, masked_arg1),
4708                                          ffecom_1 (NEGATE_EXPR,
4709                                                    integer_type_node,
4710                                                    arg2_tree))),
4711                       ffecom_2 (LSHIFT_EXPR, tree_type,
4712                                 arg1_tree,
4713                                 ffecom_2 (PLUS_EXPR, integer_type_node,
4714                                           arg2_tree,
4715                                           arg3_tree)));
4716         shift_pos
4717           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4718                       ffecom_2 (LSHIFT_EXPR, tree_type,
4719                                 arg1_tree,
4720                                 arg2_tree),
4721                       convert (tree_type,
4722                                ffecom_2 (RSHIFT_EXPR, uns_type,
4723                                          convert (uns_type, masked_arg1),
4724                                          ffecom_2 (MINUS_EXPR,
4725                                                    integer_type_node,
4726                                                    arg3_tree,
4727                                                    arg2_tree))));
4728         expr_tree
4729           = ffecom_3 (COND_EXPR, tree_type,
4730                       ffecom_truth_value
4731                       (ffecom_2 (LT_EXPR, integer_type_node,
4732                                  arg2_tree,
4733                                  integer_zero_node)),
4734                       shift_neg,
4735                       shift_pos);
4736         expr_tree
4737           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4738                       ffecom_2 (BIT_AND_EXPR, tree_type,
4739                                 mask_arg1,
4740                                 arg1_tree),
4741                       ffecom_2 (BIT_AND_EXPR, tree_type,
4742                                 ffecom_1 (BIT_NOT_EXPR, tree_type,
4743                                           mask_arg1),
4744                                 expr_tree));
4745         expr_tree
4746           = ffecom_3 (COND_EXPR, tree_type,
4747                       ffecom_truth_value
4748                       (ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
4749                                  ffecom_2 (EQ_EXPR, integer_type_node,
4750                                            ffecom_1 (ABS_EXPR,
4751                                                      integer_type_node,
4752                                                      arg2_tree),
4753                                            arg3_tree),
4754                                  ffecom_2 (EQ_EXPR, integer_type_node,
4755                                            arg2_tree,
4756                                            integer_zero_node))),
4757                       arg1_tree,
4758                       expr_tree);
4759         /* Make sure SAVE_EXPRs get referenced early enough. */
4760         expr_tree
4761           = ffecom_2 (COMPOUND_EXPR, tree_type,
4762                       convert (void_type_node, arg1_tree),
4763                       ffecom_2 (COMPOUND_EXPR, tree_type,
4764                                 convert (void_type_node, arg2_tree),
4765                                 ffecom_2 (COMPOUND_EXPR, tree_type,
4766                                           convert (void_type_node,
4767                                                    mask_arg1),
4768                                           ffecom_2 (COMPOUND_EXPR, tree_type,
4769                                                     convert (void_type_node,
4770                                                              masked_arg1),
4771                                                     expr_tree))));
4772         expr_tree
4773           = ffecom_2 (COMPOUND_EXPR, tree_type,
4774                       convert (void_type_node,
4775                                arg3_tree),
4776                       expr_tree);
4777       }
4778       return expr_tree;
4779
4780     case FFEINTRIN_impLOC:
4781       {
4782         tree arg1_tree = ffecom_expr (arg1);
4783
4784         expr_tree
4785           = convert (tree_type,
4786                      ffecom_1 (ADDR_EXPR,
4787                                build_pointer_type (TREE_TYPE (arg1_tree)),
4788                                arg1_tree));
4789       }
4790       return expr_tree;
4791
4792     case FFEINTRIN_impMVBITS:
4793       {
4794         tree arg1_tree;
4795         tree arg2_tree;
4796         tree arg3_tree;
4797         ffebld arg4 = ffebld_head (ffebld_trail (list));
4798         tree arg4_tree;
4799         tree arg4_type;
4800         ffebld arg5 = ffebld_head (ffebld_trail (ffebld_trail (list)));
4801         tree arg5_tree;
4802         tree prep_arg1;
4803         tree prep_arg4;
4804         tree arg5_plus_arg3;
4805
4806         arg2_tree = convert (integer_type_node,
4807                              ffecom_expr (arg2));
4808         arg3_tree = ffecom_save_tree (convert (integer_type_node,
4809                                                ffecom_expr (arg3)));
4810         arg4_tree = ffecom_expr_rw (NULL_TREE, arg4);
4811         arg4_type = TREE_TYPE (arg4_tree);
4812
4813         arg1_tree = ffecom_save_tree (convert (arg4_type,
4814                                                ffecom_expr (arg1)));
4815
4816         arg5_tree = ffecom_save_tree (convert (integer_type_node,
4817                                                ffecom_expr (arg5)));
4818
4819         prep_arg1
4820           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4821                       ffecom_2 (BIT_AND_EXPR, arg4_type,
4822                                 ffecom_2 (RSHIFT_EXPR, arg4_type,
4823                                           arg1_tree,
4824                                           arg2_tree),
4825                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4826                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4827                                                     ffecom_1 (BIT_NOT_EXPR,
4828                                                               arg4_type,
4829                                                               convert
4830                                                               (arg4_type,
4831                                                         integer_zero_node)),
4832                                                     arg3_tree))),
4833                       arg5_tree);
4834         arg5_plus_arg3
4835           = ffecom_save_tree (ffecom_2 (PLUS_EXPR, arg4_type,
4836                                         arg5_tree,
4837                                         arg3_tree));
4838         prep_arg4
4839           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4840                       ffecom_1 (BIT_NOT_EXPR, arg4_type,
4841                                 convert (arg4_type,
4842                                          integer_zero_node)),
4843                       arg5_plus_arg3);
4844 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4845         prep_arg4
4846           = ffecom_3 (COND_EXPR, arg4_type,
4847                       ffecom_truth_value
4848                       (ffecom_2 (NE_EXPR, integer_type_node,
4849                                  arg5_plus_arg3,
4850                                  convert (TREE_TYPE (arg5_plus_arg3),
4851                                           TYPE_SIZE (arg4_type)))),
4852                       prep_arg4,
4853                       convert (arg4_type, integer_zero_node));
4854 #endif
4855         prep_arg4
4856           = ffecom_2 (BIT_AND_EXPR, arg4_type,
4857                       arg4_tree,
4858                       ffecom_2 (BIT_IOR_EXPR, arg4_type,
4859                                 prep_arg4,
4860                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4861                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4862                                                     ffecom_1 (BIT_NOT_EXPR,
4863                                                               arg4_type,
4864                                                               convert
4865                                                               (arg4_type,
4866                                                         integer_zero_node)),
4867                                                     arg5_tree))));
4868         prep_arg1
4869           = ffecom_2 (BIT_IOR_EXPR, arg4_type,
4870                       prep_arg1,
4871                       prep_arg4);
4872 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4873         prep_arg1
4874           = ffecom_3 (COND_EXPR, arg4_type,
4875                       ffecom_truth_value
4876                       (ffecom_2 (NE_EXPR, integer_type_node,
4877                                  arg3_tree,
4878                                  convert (TREE_TYPE (arg3_tree),
4879                                           integer_zero_node))),
4880                       prep_arg1,
4881                       arg4_tree);
4882         prep_arg1
4883           = ffecom_3 (COND_EXPR, arg4_type,
4884                       ffecom_truth_value
4885                       (ffecom_2 (NE_EXPR, integer_type_node,
4886                                  arg3_tree,
4887                                  convert (TREE_TYPE (arg3_tree),
4888                                           TYPE_SIZE (arg4_type)))),
4889                       prep_arg1,
4890                       arg1_tree);
4891 #endif
4892         expr_tree
4893           = ffecom_2s (MODIFY_EXPR, void_type_node,
4894                        arg4_tree,
4895                        prep_arg1);
4896         /* Make sure SAVE_EXPRs get referenced early enough. */
4897         expr_tree
4898           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4899                       arg1_tree,
4900                       ffecom_2 (COMPOUND_EXPR, void_type_node,
4901                                 arg3_tree,
4902                                 ffecom_2 (COMPOUND_EXPR, void_type_node,
4903                                           arg5_tree,
4904                                           ffecom_2 (COMPOUND_EXPR, void_type_node,
4905                                                     arg5_plus_arg3,
4906                                                     expr_tree))));
4907         expr_tree
4908           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4909                       arg4_tree,
4910                       expr_tree);
4911
4912       }
4913       return expr_tree;
4914
4915     case FFEINTRIN_impDERF:
4916     case FFEINTRIN_impERF:
4917     case FFEINTRIN_impDERFC:
4918     case FFEINTRIN_impERFC:
4919       break;
4920
4921     case FFEINTRIN_impIARGC:
4922       /* extern int xargc; i__1 = xargc - 1; */
4923       expr_tree = ffecom_2 (MINUS_EXPR, TREE_TYPE (ffecom_tree_xargc_),
4924                             ffecom_tree_xargc_,
4925                             convert (TREE_TYPE (ffecom_tree_xargc_),
4926                                      integer_one_node));
4927       return expr_tree;
4928
4929     case FFEINTRIN_impSIGNAL_func:
4930     case FFEINTRIN_impSIGNAL_subr:
4931       {
4932         tree arg1_tree;
4933         tree arg2_tree;
4934         tree arg3_tree;
4935
4936         arg1_tree = convert (ffecom_f2c_integer_type_node,
4937                              ffecom_expr (arg1));
4938         arg1_tree = ffecom_1 (ADDR_EXPR,
4939                               build_pointer_type (TREE_TYPE (arg1_tree)),
4940                               arg1_tree);
4941
4942         /* Pass procedure as a pointer to it, anything else by value.  */
4943         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4944           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4945         else
4946           arg2_tree = ffecom_ptr_to_expr (arg2);
4947         arg2_tree = convert (TREE_TYPE (null_pointer_node),
4948                              arg2_tree);
4949
4950         if (arg3 != NULL)
4951           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4952         else
4953           arg3_tree = NULL_TREE;
4954
4955         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4956         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4957         TREE_CHAIN (arg1_tree) = arg2_tree;
4958
4959         expr_tree
4960           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4961                           ffecom_gfrt_kindtype (gfrt),
4962                           FALSE,
4963                           ((codegen_imp == FFEINTRIN_impSIGNAL_subr) ?
4964                            NULL_TREE :
4965                            tree_type),
4966                           arg1_tree,
4967                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4968                           ffebld_nonter_hook (expr));
4969
4970         if (arg3_tree != NULL_TREE)
4971           expr_tree
4972             = ffecom_modify (NULL_TREE, arg3_tree,
4973                              convert (TREE_TYPE (arg3_tree),
4974                                       expr_tree));
4975       }
4976       return expr_tree;
4977
4978     case FFEINTRIN_impALARM:
4979       {
4980         tree arg1_tree;
4981         tree arg2_tree;
4982         tree arg3_tree;
4983
4984         arg1_tree = convert (ffecom_f2c_integer_type_node,
4985                              ffecom_expr (arg1));
4986         arg1_tree = ffecom_1 (ADDR_EXPR,
4987                               build_pointer_type (TREE_TYPE (arg1_tree)),
4988                               arg1_tree);
4989
4990         /* Pass procedure as a pointer to it, anything else by value.  */
4991         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4992           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4993         else
4994           arg2_tree = ffecom_ptr_to_expr (arg2);
4995         arg2_tree = convert (TREE_TYPE (null_pointer_node),
4996                              arg2_tree);
4997
4998         if (arg3 != NULL)
4999           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5000         else
5001           arg3_tree = NULL_TREE;
5002
5003         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5004         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5005         TREE_CHAIN (arg1_tree) = arg2_tree;
5006
5007         expr_tree
5008           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5009                           ffecom_gfrt_kindtype (gfrt),
5010                           FALSE,
5011                           NULL_TREE,
5012                           arg1_tree,
5013                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5014                           ffebld_nonter_hook (expr));
5015
5016         if (arg3_tree != NULL_TREE)
5017           expr_tree
5018             = ffecom_modify (NULL_TREE, arg3_tree,
5019                              convert (TREE_TYPE (arg3_tree),
5020                                       expr_tree));
5021       }
5022       return expr_tree;
5023
5024     case FFEINTRIN_impCHDIR_subr:
5025     case FFEINTRIN_impFDATE_subr:
5026     case FFEINTRIN_impFGET_subr:
5027     case FFEINTRIN_impFPUT_subr:
5028     case FFEINTRIN_impGETCWD_subr:
5029     case FFEINTRIN_impHOSTNM_subr:
5030     case FFEINTRIN_impSYSTEM_subr:
5031     case FFEINTRIN_impUNLINK_subr:
5032       {
5033         tree arg1_len = integer_zero_node;
5034         tree arg1_tree;
5035         tree arg2_tree;
5036
5037         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5038
5039         if (arg2 != NULL)
5040           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
5041         else
5042           arg2_tree = NULL_TREE;
5043
5044         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5045         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5046         TREE_CHAIN (arg1_tree) = arg1_len;
5047
5048         expr_tree
5049           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5050                           ffecom_gfrt_kindtype (gfrt),
5051                           FALSE,
5052                           NULL_TREE,
5053                           arg1_tree,
5054                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5055                           ffebld_nonter_hook (expr));
5056
5057         if (arg2_tree != NULL_TREE)
5058           expr_tree
5059             = ffecom_modify (NULL_TREE, arg2_tree,
5060                              convert (TREE_TYPE (arg2_tree),
5061                                       expr_tree));
5062       }
5063       return expr_tree;
5064
5065     case FFEINTRIN_impEXIT:
5066       if (arg1 != NULL)
5067         break;
5068
5069       expr_tree = build_tree_list (NULL_TREE,
5070                                    ffecom_1 (ADDR_EXPR,
5071                                              build_pointer_type
5072                                              (ffecom_integer_type_node),
5073                                              integer_zero_node));
5074
5075       return
5076         ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5077                       ffecom_gfrt_kindtype (gfrt),
5078                       FALSE,
5079                       void_type_node,
5080                       expr_tree,
5081                       NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5082                       ffebld_nonter_hook (expr));
5083
5084     case FFEINTRIN_impFLUSH:
5085       if (arg1 == NULL)
5086         gfrt = FFECOM_gfrtFLUSH;
5087       else
5088         gfrt = FFECOM_gfrtFLUSH1;
5089       break;
5090
5091     case FFEINTRIN_impCHMOD_subr:
5092     case FFEINTRIN_impLINK_subr:
5093     case FFEINTRIN_impRENAME_subr:
5094     case FFEINTRIN_impSYMLNK_subr:
5095       {
5096         tree arg1_len = integer_zero_node;
5097         tree arg1_tree;
5098         tree arg2_len = integer_zero_node;
5099         tree arg2_tree;
5100         tree arg3_tree;
5101
5102         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5103         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
5104         if (arg3 != NULL)
5105           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5106         else
5107           arg3_tree = NULL_TREE;
5108
5109         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5110         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5111         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5112         arg2_len = build_tree_list (NULL_TREE, arg2_len);
5113         TREE_CHAIN (arg1_tree) = arg2_tree;
5114         TREE_CHAIN (arg2_tree) = arg1_len;
5115         TREE_CHAIN (arg1_len) = arg2_len;
5116         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5117                                   ffecom_gfrt_kindtype (gfrt),
5118                                   FALSE,
5119                                   NULL_TREE,
5120                                   arg1_tree,
5121                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5122                                   ffebld_nonter_hook (expr));
5123         if (arg3_tree != NULL_TREE)
5124           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5125                                      convert (TREE_TYPE (arg3_tree),
5126                                               expr_tree));
5127       }
5128       return expr_tree;
5129
5130     case FFEINTRIN_impLSTAT_subr:
5131     case FFEINTRIN_impSTAT_subr:
5132       {
5133         tree arg1_len = integer_zero_node;
5134         tree arg1_tree;
5135         tree arg2_tree;
5136         tree arg3_tree;
5137
5138         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5139
5140         arg2_tree = ffecom_ptr_to_expr (arg2);
5141
5142         if (arg3 != NULL)
5143           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5144         else
5145           arg3_tree = NULL_TREE;
5146
5147         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5148         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5149         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5150         TREE_CHAIN (arg1_tree) = arg2_tree;
5151         TREE_CHAIN (arg2_tree) = arg1_len;
5152         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5153                                   ffecom_gfrt_kindtype (gfrt),
5154                                   FALSE,
5155                                   NULL_TREE,
5156                                   arg1_tree,
5157                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5158                                   ffebld_nonter_hook (expr));
5159         if (arg3_tree != NULL_TREE)
5160           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5161                                      convert (TREE_TYPE (arg3_tree),
5162                                               expr_tree));
5163       }
5164       return expr_tree;
5165
5166     case FFEINTRIN_impFGETC_subr:
5167     case FFEINTRIN_impFPUTC_subr:
5168       {
5169         tree arg1_tree;
5170         tree arg2_tree;
5171         tree arg2_len = integer_zero_node;
5172         tree arg3_tree;
5173
5174         arg1_tree = convert (ffecom_f2c_integer_type_node,
5175                              ffecom_expr (arg1));
5176         arg1_tree = ffecom_1 (ADDR_EXPR,
5177                               build_pointer_type (TREE_TYPE (arg1_tree)),
5178                               arg1_tree);
5179
5180         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
5181         arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5182
5183         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5184         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5185         arg2_len = build_tree_list (NULL_TREE, arg2_len);
5186         TREE_CHAIN (arg1_tree) = arg2_tree;
5187         TREE_CHAIN (arg2_tree) = arg2_len;
5188
5189         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5190                                   ffecom_gfrt_kindtype (gfrt),
5191                                   FALSE,
5192                                   NULL_TREE,
5193                                   arg1_tree,
5194                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5195                                   ffebld_nonter_hook (expr));
5196         expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5197                                    convert (TREE_TYPE (arg3_tree),
5198                                             expr_tree));
5199       }
5200       return expr_tree;
5201
5202     case FFEINTRIN_impFSTAT_subr:
5203       {
5204         tree arg1_tree;
5205         tree arg2_tree;
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 = convert (ffecom_f2c_ptr_to_integer_type_node,
5215                              ffecom_ptr_to_expr (arg2));
5216
5217         if (arg3 == NULL)
5218           arg3_tree = NULL_TREE;
5219         else
5220           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5221
5222         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5223         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5224         TREE_CHAIN (arg1_tree) = arg2_tree;
5225         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5226                                   ffecom_gfrt_kindtype (gfrt),
5227                                   FALSE,
5228                                   NULL_TREE,
5229                                   arg1_tree,
5230                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5231                                   ffebld_nonter_hook (expr));
5232         if (arg3_tree != NULL_TREE) {
5233           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5234                                      convert (TREE_TYPE (arg3_tree),
5235                                               expr_tree));
5236         }
5237       }
5238       return expr_tree;
5239
5240     case FFEINTRIN_impKILL_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_integer_type_node,
5253                              ffecom_expr (arg2));
5254         arg2_tree = ffecom_1 (ADDR_EXPR,
5255                               build_pointer_type (TREE_TYPE (arg2_tree)),
5256                               arg2_tree);
5257
5258         if (arg3 == NULL)
5259           arg3_tree = NULL_TREE;
5260         else
5261           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5262
5263         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5264         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5265         TREE_CHAIN (arg1_tree) = arg2_tree;
5266         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5267                                   ffecom_gfrt_kindtype (gfrt),
5268                                   FALSE,
5269                                   NULL_TREE,
5270                                   arg1_tree,
5271                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5272                                   ffebld_nonter_hook (expr));
5273         if (arg3_tree != NULL_TREE) {
5274           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5275                                      convert (TREE_TYPE (arg3_tree),
5276                                               expr_tree));
5277         }
5278       }
5279       return expr_tree;
5280
5281     case FFEINTRIN_impCTIME_subr:
5282     case FFEINTRIN_impTTYNAM_subr:
5283       {
5284         tree arg1_len = integer_zero_node;
5285         tree arg1_tree;
5286         tree arg2_tree;
5287
5288         arg1_tree = ffecom_arg_ptr_to_expr (arg2, &arg1_len);
5289
5290         arg2_tree = convert (((codegen_imp == FFEINTRIN_impCTIME_subr) ?
5291                               ffecom_f2c_longint_type_node :
5292                               ffecom_f2c_integer_type_node),
5293                              ffecom_expr (arg1));
5294         arg2_tree = ffecom_1 (ADDR_EXPR,
5295                               build_pointer_type (TREE_TYPE (arg2_tree)),
5296                               arg2_tree);
5297
5298         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5299         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5300         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5301         TREE_CHAIN (arg1_len) = arg2_tree;
5302         TREE_CHAIN (arg1_tree) = arg1_len;
5303
5304         expr_tree
5305           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5306                           ffecom_gfrt_kindtype (gfrt),
5307                           FALSE,
5308                           NULL_TREE,
5309                           arg1_tree,
5310                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5311                           ffebld_nonter_hook (expr));
5312         TREE_SIDE_EFFECTS (expr_tree) = 1;
5313       }
5314       return expr_tree;
5315
5316     case FFEINTRIN_impIRAND:
5317     case FFEINTRIN_impRAND:
5318       /* Arg defaults to 0 (normal random case) */
5319       {
5320         tree arg1_tree;
5321
5322         if (arg1 == NULL)
5323           arg1_tree = ffecom_integer_zero_node;
5324         else
5325           arg1_tree = ffecom_expr (arg1);
5326         arg1_tree = convert (ffecom_f2c_integer_type_node,
5327                              arg1_tree);
5328         arg1_tree = ffecom_1 (ADDR_EXPR,
5329                               build_pointer_type (TREE_TYPE (arg1_tree)),
5330                               arg1_tree);
5331         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5332
5333         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5334                                   ffecom_gfrt_kindtype (gfrt),
5335                                   FALSE,
5336                                   ((codegen_imp == FFEINTRIN_impIRAND) ?
5337                                    ffecom_f2c_integer_type_node :
5338                                    ffecom_f2c_real_type_node),
5339                                   arg1_tree,
5340                                   dest_tree, dest, dest_used,
5341                                   NULL_TREE, TRUE,
5342                                   ffebld_nonter_hook (expr));
5343       }
5344       return expr_tree;
5345
5346     case FFEINTRIN_impFTELL_subr:
5347     case FFEINTRIN_impUMASK_subr:
5348       {
5349         tree arg1_tree;
5350         tree arg2_tree;
5351
5352         arg1_tree = convert (ffecom_f2c_integer_type_node,
5353                              ffecom_expr (arg1));
5354         arg1_tree = ffecom_1 (ADDR_EXPR,
5355                               build_pointer_type (TREE_TYPE (arg1_tree)),
5356                               arg1_tree);
5357
5358         if (arg2 == NULL)
5359           arg2_tree = NULL_TREE;
5360         else
5361           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
5362
5363         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5364                                   ffecom_gfrt_kindtype (gfrt),
5365                                   FALSE,
5366                                   NULL_TREE,
5367                                   build_tree_list (NULL_TREE, arg1_tree),
5368                                   NULL_TREE, NULL, NULL, NULL_TREE,
5369                                   TRUE,
5370                                   ffebld_nonter_hook (expr));
5371         if (arg2_tree != NULL_TREE) {
5372           expr_tree = ffecom_modify (NULL_TREE, arg2_tree,
5373                                      convert (TREE_TYPE (arg2_tree),
5374                                               expr_tree));
5375         }
5376       }
5377       return expr_tree;
5378
5379     case FFEINTRIN_impCPU_TIME:
5380     case FFEINTRIN_impSECOND_subr:
5381       {
5382         tree arg1_tree;
5383
5384         arg1_tree = ffecom_expr_w (NULL_TREE, arg1);
5385
5386         expr_tree
5387           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5388                           ffecom_gfrt_kindtype (gfrt),
5389                           FALSE,
5390                           NULL_TREE,
5391                           NULL_TREE,
5392                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5393                           ffebld_nonter_hook (expr));
5394
5395         expr_tree
5396           = ffecom_modify (NULL_TREE, arg1_tree,
5397                            convert (TREE_TYPE (arg1_tree),
5398                                     expr_tree));
5399       }
5400       return expr_tree;
5401
5402     case FFEINTRIN_impDTIME_subr:
5403     case FFEINTRIN_impETIME_subr:
5404       {
5405         tree arg1_tree;
5406         tree result_tree;
5407
5408         result_tree = ffecom_expr_w (NULL_TREE, arg2);
5409
5410         arg1_tree = ffecom_ptr_to_expr (arg1);
5411
5412         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5413                                   ffecom_gfrt_kindtype (gfrt),
5414                                   FALSE,
5415                                   NULL_TREE,
5416                                   build_tree_list (NULL_TREE, arg1_tree),
5417                                   NULL_TREE, NULL, NULL, NULL_TREE,
5418                                   TRUE,
5419                                   ffebld_nonter_hook (expr));
5420         expr_tree = ffecom_modify (NULL_TREE, result_tree,
5421                                    convert (TREE_TYPE (result_tree),
5422                                             expr_tree));
5423       }
5424       return expr_tree;
5425
5426       /* Straightforward calls of libf2c routines: */
5427     case FFEINTRIN_impABORT:
5428     case FFEINTRIN_impACCESS:
5429     case FFEINTRIN_impBESJ0:
5430     case FFEINTRIN_impBESJ1:
5431     case FFEINTRIN_impBESJN:
5432     case FFEINTRIN_impBESY0:
5433     case FFEINTRIN_impBESY1:
5434     case FFEINTRIN_impBESYN:
5435     case FFEINTRIN_impCHDIR_func:
5436     case FFEINTRIN_impCHMOD_func:
5437     case FFEINTRIN_impDATE:
5438     case FFEINTRIN_impDATE_AND_TIME:
5439     case FFEINTRIN_impDBESJ0:
5440     case FFEINTRIN_impDBESJ1:
5441     case FFEINTRIN_impDBESJN:
5442     case FFEINTRIN_impDBESY0:
5443     case FFEINTRIN_impDBESY1:
5444     case FFEINTRIN_impDBESYN:
5445     case FFEINTRIN_impDTIME_func:
5446     case FFEINTRIN_impETIME_func:
5447     case FFEINTRIN_impFGETC_func:
5448     case FFEINTRIN_impFGET_func:
5449     case FFEINTRIN_impFNUM:
5450     case FFEINTRIN_impFPUTC_func:
5451     case FFEINTRIN_impFPUT_func:
5452     case FFEINTRIN_impFSEEK:
5453     case FFEINTRIN_impFSTAT_func:
5454     case FFEINTRIN_impFTELL_func:
5455     case FFEINTRIN_impGERROR:
5456     case FFEINTRIN_impGETARG:
5457     case FFEINTRIN_impGETCWD_func:
5458     case FFEINTRIN_impGETENV:
5459     case FFEINTRIN_impGETGID:
5460     case FFEINTRIN_impGETLOG:
5461     case FFEINTRIN_impGETPID:
5462     case FFEINTRIN_impGETUID:
5463     case FFEINTRIN_impGMTIME:
5464     case FFEINTRIN_impHOSTNM_func:
5465     case FFEINTRIN_impIDATE_unix:
5466     case FFEINTRIN_impIDATE_vxt:
5467     case FFEINTRIN_impIERRNO:
5468     case FFEINTRIN_impISATTY:
5469     case FFEINTRIN_impITIME:
5470     case FFEINTRIN_impKILL_func:
5471     case FFEINTRIN_impLINK_func:
5472     case FFEINTRIN_impLNBLNK:
5473     case FFEINTRIN_impLSTAT_func:
5474     case FFEINTRIN_impLTIME:
5475     case FFEINTRIN_impMCLOCK8:
5476     case FFEINTRIN_impMCLOCK:
5477     case FFEINTRIN_impPERROR:
5478     case FFEINTRIN_impRENAME_func:
5479     case FFEINTRIN_impSECNDS:
5480     case FFEINTRIN_impSECOND_func:
5481     case FFEINTRIN_impSLEEP:
5482     case FFEINTRIN_impSRAND:
5483     case FFEINTRIN_impSTAT_func:
5484     case FFEINTRIN_impSYMLNK_func:
5485     case FFEINTRIN_impSYSTEM_CLOCK:
5486     case FFEINTRIN_impSYSTEM_func:
5487     case FFEINTRIN_impTIME8:
5488     case FFEINTRIN_impTIME_unix:
5489     case FFEINTRIN_impTIME_vxt:
5490     case FFEINTRIN_impUMASK_func:
5491     case FFEINTRIN_impUNLINK_func:
5492       break;
5493
5494     case FFEINTRIN_impCTIME_func:       /* CHARACTER functions not handled here. */
5495     case FFEINTRIN_impFDATE_func:       /* CHARACTER functions not handled here. */
5496     case FFEINTRIN_impTTYNAM_func:      /* CHARACTER functions not handled here. */
5497     case FFEINTRIN_impNONE:
5498     case FFEINTRIN_imp:         /* Hush up gcc warning. */
5499       fprintf (stderr, "No %s implementation.\n",
5500                ffeintrin_name_implementation (ffebld_symter_implementation (ffebld_left (expr))));
5501       assert ("unimplemented intrinsic" == NULL);
5502       return error_mark_node;
5503     }
5504
5505   assert (gfrt != FFECOM_gfrt); /* Must have an implementation! */
5506
5507   expr_tree = ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt),
5508                                     ffebld_right (expr));
5509
5510   return ffecom_call_ (ffecom_gfrt_tree_ (gfrt), ffecom_gfrt_kindtype (gfrt),
5511                        (ffe_is_f2c_library () && ffecom_gfrt_complex_[gfrt]),
5512                        tree_type,
5513                        expr_tree, dest_tree, dest, dest_used,
5514                        NULL_TREE, TRUE,
5515                        ffebld_nonter_hook (expr));
5516
5517   /* See bottom of this file for f2c transforms used to determine
5518      many of the above implementations.  The info seems to confuse
5519      Emacs's C mode indentation, which is why it's been moved to
5520      the bottom of this source file.  */
5521 }
5522
5523 #endif
5524 /* For power (exponentiation) where right-hand operand is type INTEGER,
5525    generate in-line code to do it the fast way (which, if the operand
5526    is a constant, might just mean a series of multiplies).  */
5527
5528 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5529 static tree
5530 ffecom_expr_power_integer_ (ffebld expr)
5531 {
5532   tree l = ffecom_expr (ffebld_left (expr));
5533   tree r = ffecom_expr (ffebld_right (expr));
5534   tree ltype = TREE_TYPE (l);
5535   tree rtype = TREE_TYPE (r);
5536   tree result = NULL_TREE;
5537
5538   if (l == error_mark_node
5539       || r == error_mark_node)
5540     return error_mark_node;
5541
5542   if (TREE_CODE (r) == INTEGER_CST)
5543     {
5544       int sgn = tree_int_cst_sgn (r);
5545
5546       if (sgn == 0)
5547         return convert (ltype, integer_one_node);
5548
5549       if ((TREE_CODE (ltype) == INTEGER_TYPE)
5550           && (sgn < 0))
5551         {
5552           /* Reciprocal of integer is either 0, -1, or 1, so after
5553              calculating that (which we leave to the back end to do
5554              or not do optimally), don't bother with any multiplying.  */
5555
5556           result = ffecom_tree_divide_ (ltype,
5557                                         convert (ltype, integer_one_node),
5558                                         l,
5559                                         NULL_TREE, NULL, NULL, NULL_TREE);
5560           r = ffecom_1 (NEGATE_EXPR,
5561                         rtype,
5562                         r);
5563           if ((TREE_INT_CST_LOW (r) & 1) == 0)
5564             result = ffecom_1 (ABS_EXPR, rtype,
5565                                result);
5566         }
5567
5568       /* Generate appropriate series of multiplies, preceded
5569          by divide if the exponent is negative.  */
5570
5571       l = save_expr (l);
5572
5573       if (sgn < 0)
5574         {
5575           l = ffecom_tree_divide_ (ltype,
5576                                    convert (ltype, integer_one_node),
5577                                    l,
5578                                    NULL_TREE, NULL, NULL,
5579                                    ffebld_nonter_hook (expr));
5580           r = ffecom_1 (NEGATE_EXPR, rtype, r);
5581           assert (TREE_CODE (r) == INTEGER_CST);
5582
5583           if (tree_int_cst_sgn (r) < 0)
5584             {                   /* The "most negative" number.  */
5585               r = ffecom_1 (NEGATE_EXPR, rtype,
5586                             ffecom_2 (RSHIFT_EXPR, rtype,
5587                                       r,
5588                                       integer_one_node));
5589               l = save_expr (l);
5590               l = ffecom_2 (MULT_EXPR, ltype,
5591                             l,
5592                             l);
5593             }
5594         }
5595
5596       for (;;)
5597         {
5598           if (TREE_INT_CST_LOW (r) & 1)
5599             {
5600               if (result == NULL_TREE)
5601                 result = l;
5602               else
5603                 result = ffecom_2 (MULT_EXPR, ltype,
5604                                    result,
5605                                    l);
5606             }
5607
5608           r = ffecom_2 (RSHIFT_EXPR, rtype,
5609                         r,
5610                         integer_one_node);
5611           if (integer_zerop (r))
5612             break;
5613           assert (TREE_CODE (r) == INTEGER_CST);
5614
5615           l = save_expr (l);
5616           l = ffecom_2 (MULT_EXPR, ltype,
5617                         l,
5618                         l);
5619         }
5620       return result;
5621     }
5622
5623   /* Though rhs isn't a constant, in-line code cannot be expanded
5624      while transforming dummies
5625      because the back end cannot be easily convinced to generate
5626      stores (MODIFY_EXPR), handle temporaries, and so on before
5627      all the appropriate rtx's have been generated for things like
5628      dummy args referenced in rhs -- which doesn't happen until
5629      store_parm_decls() is called (expand_function_start, I believe,
5630      does the actual rtx-stuffing of PARM_DECLs).
5631
5632      So, in this case, let the caller generate the call to the
5633      run-time-library function to evaluate the power for us.  */
5634
5635   if (ffecom_transform_only_dummies_)
5636     return NULL_TREE;
5637
5638   /* Right-hand operand not a constant, expand in-line code to figure
5639      out how to do the multiplies, &c.
5640
5641      The returned expression is expressed this way in GNU C, where l and
5642      r are the "inputs":
5643
5644      ({ typeof (r) rtmp = r;
5645         typeof (l) ltmp = l;
5646         typeof (l) result;
5647
5648         if (rtmp == 0)
5649           result = 1;
5650         else
5651           {
5652             if ((basetypeof (l) == basetypeof (int))
5653                 && (rtmp < 0))
5654               {
5655                 result = ((typeof (l)) 1) / ltmp;
5656                 if ((ltmp < 0) && (((-rtmp) & 1) == 0))
5657                   result = -result;
5658               }
5659             else
5660               {
5661                 result = 1;
5662                 if ((basetypeof (l) != basetypeof (int))
5663                     && (rtmp < 0))
5664                   {
5665                     ltmp = ((typeof (l)) 1) / ltmp;
5666                     rtmp = -rtmp;
5667                     if (rtmp < 0)
5668                       {
5669                         rtmp = -(rtmp >> 1);
5670                         ltmp *= ltmp;
5671                       }
5672                   }
5673                 for (;;)
5674                   {
5675                     if (rtmp & 1)
5676                       result *= ltmp;
5677                     if ((rtmp >>= 1) == 0)
5678                       break;
5679                     ltmp *= ltmp;
5680                   }
5681               }
5682           }
5683         result;
5684      })
5685
5686      Note that some of the above is compile-time collapsable, such as
5687      the first part of the if statements that checks the base type of
5688      l against int.  The if statements are phrased that way to suggest
5689      an easy way to generate the if/else constructs here, knowing that
5690      the back end should (and probably does) eliminate the resulting
5691      dead code (either the int case or the non-int case), something
5692      it couldn't do without the redundant phrasing, requiring explicit
5693      dead-code elimination here, which would be kind of difficult to
5694      read.  */
5695
5696   {
5697     tree rtmp;
5698     tree ltmp;
5699     tree divide;
5700     tree basetypeof_l_is_int;
5701     tree se;
5702     tree t;
5703
5704     basetypeof_l_is_int
5705       = build_int_2 ((TREE_CODE (ltype) == INTEGER_TYPE), 0);
5706
5707     se = expand_start_stmt_expr ();
5708
5709     ffecom_start_compstmt ();
5710
5711 #ifndef HAHA
5712     rtmp = ffecom_make_tempvar ("power_r", rtype,
5713                                 FFETARGET_charactersizeNONE, -1);
5714     ltmp = ffecom_make_tempvar ("power_l", ltype,
5715                                 FFETARGET_charactersizeNONE, -1);
5716     result = ffecom_make_tempvar ("power_res", ltype,
5717                                   FFETARGET_charactersizeNONE, -1);
5718     if (TREE_CODE (ltype) == COMPLEX_TYPE
5719         || TREE_CODE (ltype) == RECORD_TYPE)
5720       divide = ffecom_make_tempvar ("power_div", ltype,
5721                                     FFETARGET_charactersizeNONE, -1);
5722     else
5723       divide = NULL_TREE;
5724 #else  /* HAHA */
5725     {
5726       tree hook;
5727
5728       hook = ffebld_nonter_hook (expr);
5729       assert (hook);
5730       assert (TREE_CODE (hook) == TREE_VEC);
5731       assert (TREE_VEC_LENGTH (hook) == 4);
5732       rtmp = TREE_VEC_ELT (hook, 0);
5733       ltmp = TREE_VEC_ELT (hook, 1);
5734       result = TREE_VEC_ELT (hook, 2);
5735       divide = TREE_VEC_ELT (hook, 3);
5736       if (TREE_CODE (ltype) == COMPLEX_TYPE
5737           || TREE_CODE (ltype) == RECORD_TYPE)
5738         assert (divide);
5739       else
5740         assert (! divide);
5741     }
5742 #endif  /* HAHA */
5743
5744     expand_expr_stmt (ffecom_modify (void_type_node,
5745                                      rtmp,
5746                                      r));
5747     expand_expr_stmt (ffecom_modify (void_type_node,
5748                                      ltmp,
5749                                      l));
5750     expand_start_cond (ffecom_truth_value
5751                        (ffecom_2 (EQ_EXPR, integer_type_node,
5752                                   rtmp,
5753                                   convert (rtype, integer_zero_node))),
5754                        0);
5755     expand_expr_stmt (ffecom_modify (void_type_node,
5756                                      result,
5757                                      convert (ltype, integer_one_node)));
5758     expand_start_else ();
5759     if (! integer_zerop (basetypeof_l_is_int))
5760       {
5761         expand_start_cond (ffecom_2 (LT_EXPR, integer_type_node,
5762                                      rtmp,
5763                                      convert (rtype,
5764                                               integer_zero_node)),
5765                            0);
5766         expand_expr_stmt (ffecom_modify (void_type_node,
5767                                          result,
5768                                          ffecom_tree_divide_
5769                                          (ltype,
5770                                           convert (ltype, integer_one_node),
5771                                           ltmp,
5772                                           NULL_TREE, NULL, NULL,
5773                                           divide)));
5774         expand_start_cond (ffecom_truth_value
5775                            (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5776                                       ffecom_2 (LT_EXPR, integer_type_node,
5777                                                 ltmp,
5778                                                 convert (ltype,
5779                                                          integer_zero_node)),
5780                                       ffecom_2 (EQ_EXPR, integer_type_node,
5781                                                 ffecom_2 (BIT_AND_EXPR,
5782                                                           rtype,
5783                                                           ffecom_1 (NEGATE_EXPR,
5784                                                                     rtype,
5785                                                                     rtmp),
5786                                                           convert (rtype,
5787                                                                    integer_one_node)),
5788                                                 convert (rtype,
5789                                                          integer_zero_node)))),
5790                            0);
5791         expand_expr_stmt (ffecom_modify (void_type_node,
5792                                          result,
5793                                          ffecom_1 (NEGATE_EXPR,
5794                                                    ltype,
5795                                                    result)));
5796         expand_end_cond ();
5797         expand_start_else ();
5798       }
5799     expand_expr_stmt (ffecom_modify (void_type_node,
5800                                      result,
5801                                      convert (ltype, integer_one_node)));
5802     expand_start_cond (ffecom_truth_value
5803                        (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5804                                   ffecom_truth_value_invert
5805                                   (basetypeof_l_is_int),
5806                                   ffecom_2 (LT_EXPR, integer_type_node,
5807                                             rtmp,
5808                                             convert (rtype,
5809                                                      integer_zero_node)))),
5810                        0);
5811     expand_expr_stmt (ffecom_modify (void_type_node,
5812                                      ltmp,
5813                                      ffecom_tree_divide_
5814                                      (ltype,
5815                                       convert (ltype, integer_one_node),
5816                                       ltmp,
5817                                       NULL_TREE, NULL, NULL,
5818                                       divide)));
5819     expand_expr_stmt (ffecom_modify (void_type_node,
5820                                      rtmp,
5821                                      ffecom_1 (NEGATE_EXPR, rtype,
5822                                                rtmp)));
5823     expand_start_cond (ffecom_truth_value
5824                        (ffecom_2 (LT_EXPR, integer_type_node,
5825                                   rtmp,
5826                                   convert (rtype, integer_zero_node))),
5827                        0);
5828     expand_expr_stmt (ffecom_modify (void_type_node,
5829                                      rtmp,
5830                                      ffecom_1 (NEGATE_EXPR, rtype,
5831                                                ffecom_2 (RSHIFT_EXPR,
5832                                                          rtype,
5833                                                          rtmp,
5834                                                          integer_one_node))));
5835     expand_expr_stmt (ffecom_modify (void_type_node,
5836                                      ltmp,
5837                                      ffecom_2 (MULT_EXPR, ltype,
5838                                                ltmp,
5839                                                ltmp)));
5840     expand_end_cond ();
5841     expand_end_cond ();
5842     expand_start_loop (1);
5843     expand_start_cond (ffecom_truth_value
5844                        (ffecom_2 (BIT_AND_EXPR, rtype,
5845                                   rtmp,
5846                                   convert (rtype, integer_one_node))),
5847                        0);
5848     expand_expr_stmt (ffecom_modify (void_type_node,
5849                                      result,
5850                                      ffecom_2 (MULT_EXPR, ltype,
5851                                                result,
5852                                                ltmp)));
5853     expand_end_cond ();
5854     expand_exit_loop_if_false (NULL,
5855                                ffecom_truth_value
5856                                (ffecom_modify (rtype,
5857                                                rtmp,
5858                                                ffecom_2 (RSHIFT_EXPR,
5859                                                          rtype,
5860                                                          rtmp,
5861                                                          integer_one_node))));
5862     expand_expr_stmt (ffecom_modify (void_type_node,
5863                                      ltmp,
5864                                      ffecom_2 (MULT_EXPR, ltype,
5865                                                ltmp,
5866                                                ltmp)));
5867     expand_end_loop ();
5868     expand_end_cond ();
5869     if (!integer_zerop (basetypeof_l_is_int))
5870       expand_end_cond ();
5871     expand_expr_stmt (result);
5872
5873     t = ffecom_end_compstmt ();
5874
5875     result = expand_end_stmt_expr (se);
5876
5877     /* This code comes from c-parse.in, after its expand_end_stmt_expr.  */
5878
5879     if (TREE_CODE (t) == BLOCK)
5880       {
5881         /* Make a BIND_EXPR for the BLOCK already made.  */
5882         result = build (BIND_EXPR, TREE_TYPE (result),
5883                         NULL_TREE, result, t);
5884         /* Remove the block from the tree at this point.
5885            It gets put back at the proper place
5886            when the BIND_EXPR is expanded.  */
5887         delete_block (t);
5888       }
5889     else
5890       result = t;
5891   }
5892
5893   return result;
5894 }
5895
5896 #endif
5897 /* ffecom_expr_transform_ -- Transform symbols in expr
5898
5899    ffebld expr;  // FFE expression.
5900    ffecom_expr_transform_ (expr);
5901
5902    Recursive descent on expr while transforming any untransformed SYMTERs.  */
5903
5904 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5905 static void
5906 ffecom_expr_transform_ (ffebld expr)
5907 {
5908   tree t;
5909   ffesymbol s;
5910
5911 tail_recurse:                   /* :::::::::::::::::::: */
5912
5913   if (expr == NULL)
5914     return;
5915
5916   switch (ffebld_op (expr))
5917     {
5918     case FFEBLD_opSYMTER:
5919       s = ffebld_symter (expr);
5920       t = ffesymbol_hook (s).decl_tree;
5921       if ((t == NULL_TREE)
5922           && ((ffesymbol_kind (s) != FFEINFO_kindNONE)
5923               || ((ffesymbol_where (s) != FFEINFO_whereNONE)
5924                   && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC))))
5925         {
5926           s = ffecom_sym_transform_ (s);
5927           t = ffesymbol_hook (s).decl_tree;     /* Sfunc expr non-dummy,
5928                                                    DIMENSION expr? */
5929         }
5930       break;                    /* Ok if (t == NULL) here. */
5931
5932     case FFEBLD_opITEM:
5933       ffecom_expr_transform_ (ffebld_head (expr));
5934       expr = ffebld_trail (expr);
5935       goto tail_recurse;        /* :::::::::::::::::::: */
5936
5937     default:
5938       break;
5939     }
5940
5941   switch (ffebld_arity (expr))
5942     {
5943     case 2:
5944       ffecom_expr_transform_ (ffebld_left (expr));
5945       expr = ffebld_right (expr);
5946       goto tail_recurse;        /* :::::::::::::::::::: */
5947
5948     case 1:
5949       expr = ffebld_left (expr);
5950       goto tail_recurse;        /* :::::::::::::::::::: */
5951
5952     default:
5953       break;
5954     }
5955
5956   return;
5957 }
5958
5959 #endif
5960 /* Make a type based on info in live f2c.h file.  */
5961
5962 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5963 static void
5964 ffecom_f2c_make_type_ (tree *type, int tcode, const char *name)
5965 {
5966   switch (tcode)
5967     {
5968     case FFECOM_f2ccodeCHAR:
5969       *type = make_signed_type (CHAR_TYPE_SIZE);
5970       break;
5971
5972     case FFECOM_f2ccodeSHORT:
5973       *type = make_signed_type (SHORT_TYPE_SIZE);
5974       break;
5975
5976     case FFECOM_f2ccodeINT:
5977       *type = make_signed_type (INT_TYPE_SIZE);
5978       break;
5979
5980     case FFECOM_f2ccodeLONG:
5981       *type = make_signed_type (LONG_TYPE_SIZE);
5982       break;
5983
5984     case FFECOM_f2ccodeLONGLONG:
5985       *type = make_signed_type (LONG_LONG_TYPE_SIZE);
5986       break;
5987
5988     case FFECOM_f2ccodeCHARPTR:
5989       *type = build_pointer_type (DEFAULT_SIGNED_CHAR
5990                                   ? signed_char_type_node
5991                                   : unsigned_char_type_node);
5992       break;
5993
5994     case FFECOM_f2ccodeFLOAT:
5995       *type = make_node (REAL_TYPE);
5996       TYPE_PRECISION (*type) = FLOAT_TYPE_SIZE;
5997       layout_type (*type);
5998       break;
5999
6000     case FFECOM_f2ccodeDOUBLE:
6001       *type = make_node (REAL_TYPE);
6002       TYPE_PRECISION (*type) = DOUBLE_TYPE_SIZE;
6003       layout_type (*type);
6004       break;
6005
6006     case FFECOM_f2ccodeLONGDOUBLE:
6007       *type = make_node (REAL_TYPE);
6008       TYPE_PRECISION (*type) = LONG_DOUBLE_TYPE_SIZE;
6009       layout_type (*type);
6010       break;
6011
6012     case FFECOM_f2ccodeTWOREALS:
6013       *type = ffecom_make_complex_type_ (ffecom_f2c_real_type_node);
6014       break;
6015
6016     case FFECOM_f2ccodeTWODOUBLEREALS:
6017       *type = ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node);
6018       break;
6019
6020     default:
6021       assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL);
6022       *type = error_mark_node;
6023       return;
6024     }
6025
6026   pushdecl (build_decl (TYPE_DECL,
6027                         ffecom_get_invented_identifier ("__g77_f2c_%s", name),
6028                         *type));
6029 }
6030
6031 #endif
6032 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6033 /* Set the f2c list-directed-I/O code for whatever (integral) type has the
6034    given size.  */
6035
6036 static void
6037 ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
6038                           int code)
6039 {
6040   int j;
6041   tree t;
6042
6043   for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
6044     if ((t = ffecom_tree_type[bt][j]) != NULL_TREE
6045         && compare_tree_int (TYPE_SIZE (t), size) == 0)
6046       {
6047         assert (code != -1);
6048         ffecom_f2c_typecode_[bt][j] = code;
6049         code = -1;
6050       }
6051 }
6052
6053 #endif
6054 /* Finish up globals after doing all program units in file
6055
6056    Need to handle only uninitialized COMMON areas.  */
6057
6058 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6059 static ffeglobal
6060 ffecom_finish_global_ (ffeglobal global)
6061 {
6062   tree cbtype;
6063   tree cbt;
6064   tree size;
6065
6066   if (ffeglobal_type (global) != FFEGLOBAL_typeCOMMON)
6067       return global;
6068
6069   if (ffeglobal_common_init (global))
6070       return global;
6071
6072   cbt = ffeglobal_hook (global);
6073   if ((cbt == NULL_TREE)
6074       || !ffeglobal_common_have_size (global))
6075     return global;              /* No need to make common, never ref'd. */
6076
6077   suspend_momentary ();
6078
6079   DECL_EXTERNAL (cbt) = 0;
6080
6081   /* Give the array a size now.  */
6082
6083   size = build_int_2 ((ffeglobal_common_size (global)
6084                       + ffeglobal_common_pad (global)) - 1,
6085                       0);
6086
6087   cbtype = TREE_TYPE (cbt);
6088   TYPE_DOMAIN (cbtype) = build_range_type (integer_type_node,
6089                                            integer_zero_node,
6090                                            size);
6091   if (!TREE_TYPE (size))
6092     TREE_TYPE (size) = TYPE_DOMAIN (cbtype);
6093   layout_type (cbtype);
6094
6095   cbt = start_decl (cbt, FALSE);
6096   assert (cbt == ffeglobal_hook (global));
6097
6098   finish_decl (cbt, NULL_TREE, FALSE);
6099
6100   return global;
6101 }
6102
6103 #endif
6104 /* Finish up any untransformed symbols.  */
6105
6106 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6107 static ffesymbol
6108 ffecom_finish_symbol_transform_ (ffesymbol s)
6109 {
6110   if ((s == NULL) || (TREE_CODE (current_function_decl) == ERROR_MARK))
6111     return s;
6112
6113   /* It's easy to know to transform an untransformed symbol, to make sure
6114      we put out debugging info for it.  But COMMON variables, unlike
6115      EQUIVALENCE ones, aren't given declarations in addition to the
6116      tree expressions that specify offsets, because COMMON variables
6117      can be referenced in the outer scope where only dummy arguments
6118      (PARM_DECLs) should really be seen.  To be safe, just don't do any
6119      VAR_DECLs for COMMON variables when we transform them for real
6120      use, and therefore we do all the VAR_DECL creating here.  */
6121
6122   if (ffesymbol_hook (s).decl_tree == NULL_TREE)
6123     {
6124       if (ffesymbol_kind (s) != FFEINFO_kindNONE
6125           || (ffesymbol_where (s) != FFEINFO_whereNONE
6126               && ffesymbol_where (s) != FFEINFO_whereINTRINSIC
6127               && ffesymbol_where (s) != FFEINFO_whereDUMMY))
6128         /* Not transformed, and not CHARACTER*(*), and not a dummy
6129            argument, which can happen only if the entry point names
6130            it "rides in on" are all invalidated for other reasons.  */
6131         s = ffecom_sym_transform_ (s);
6132     }
6133
6134   if ((ffesymbol_where (s) == FFEINFO_whereCOMMON)
6135       && (ffesymbol_hook (s).decl_tree != error_mark_node))
6136     {
6137       int yes = suspend_momentary ();
6138
6139       /* This isn't working, at least for dbxout.  The .s file looks
6140          okay to me (burley), but in gdb 4.9 at least, the variables
6141          appear to reside somewhere outside of the common area, so
6142          it doesn't make sense to mislead anyone by generating the info
6143          on those variables until this is fixed.  NOTE: Same problem
6144          with EQUIVALENCE, sadly...see similar #if later.  */
6145       ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s)),
6146                              ffesymbol_storage (s));
6147
6148       resume_momentary (yes);
6149     }
6150
6151   return s;
6152 }
6153
6154 #endif
6155 /* Append underscore(s) to name before calling get_identifier.  "us"
6156    is nonzero if the name already contains an underscore and thus
6157    needs two underscores appended.  */
6158
6159 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6160 static tree
6161 ffecom_get_appended_identifier_ (char us, const char *name)
6162 {
6163   int i;
6164   char *newname;
6165   tree id;
6166
6167   newname = xmalloc ((i = strlen (name)) + 1
6168                      + ffe_is_underscoring ()
6169                      + us);
6170   memcpy (newname, name, i);
6171   newname[i] = '_';
6172   newname[i + us] = '_';
6173   newname[i + 1 + us] = '\0';
6174   id = get_identifier (newname);
6175
6176   free (newname);
6177
6178   return id;
6179 }
6180
6181 #endif
6182 /* Decide whether to append underscore to name before calling
6183    get_identifier.  */
6184
6185 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6186 static tree
6187 ffecom_get_external_identifier_ (ffesymbol s)
6188 {
6189   char us;
6190   const char *name = ffesymbol_text (s);
6191
6192   /* If name is a built-in name, just return it as is.  */
6193
6194   if (!ffe_is_underscoring ()
6195       || (strcmp (name, FFETARGET_nameBLANK_COMMON) == 0)
6196 #if FFETARGET_isENFORCED_MAIN_NAME
6197       || (strcmp (name, FFETARGET_nameENFORCED_NAME) == 0)
6198 #else
6199       || (strcmp (name, FFETARGET_nameUNNAMED_MAIN) == 0)
6200 #endif
6201       || (strcmp (name, FFETARGET_nameUNNAMED_BLOCK_DATA) == 0))
6202     return get_identifier (name);
6203
6204   us = ffe_is_second_underscore ()
6205     ? (strchr (name, '_') != NULL)
6206       : 0;
6207
6208   return ffecom_get_appended_identifier_ (us, name);
6209 }
6210
6211 #endif
6212 /* Decide whether to append underscore to internal name before calling
6213    get_identifier.
6214
6215    This is for non-external, top-function-context names only.  Transform
6216    identifier so it doesn't conflict with the transformed result
6217    of using a _different_ external name.  E.g. if "CALL FOO" is
6218    transformed into "FOO_();", then the variable in "FOO_ = 3"
6219    must be transformed into something that does not conflict, since
6220    these two things should be independent.
6221
6222    The transformation is as follows.  If the name does not contain
6223    an underscore, there is no possible conflict, so just return.
6224    If the name does contain an underscore, then transform it just
6225    like we transform an external identifier.  */
6226
6227 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6228 static tree
6229 ffecom_get_identifier_ (const char *name)
6230 {
6231   /* If name does not contain an underscore, just return it as is.  */
6232
6233   if (!ffe_is_underscoring ()
6234       || (strchr (name, '_') == NULL))
6235     return get_identifier (name);
6236
6237   return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
6238                                           name);
6239 }
6240
6241 #endif
6242 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
6243
6244    tree t;
6245    ffesymbol s;  // kindFUNCTION, whereIMMEDIATE.
6246    t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
6247          ffesymbol_kindtype(s));
6248
6249    Call after setting up containing function and getting trees for all
6250    other symbols.  */
6251
6252 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6253 static tree
6254 ffecom_gen_sfuncdef_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt)
6255 {
6256   ffebld expr = ffesymbol_sfexpr (s);
6257   tree type;
6258   tree func;
6259   tree result;
6260   bool charfunc = (bt == FFEINFO_basictypeCHARACTER);
6261   static bool recurse = FALSE;
6262   int yes;
6263   int old_lineno = lineno;
6264   const char *old_input_filename = input_filename;
6265
6266   ffecom_nested_entry_ = s;
6267
6268   /* For now, we don't have a handy pointer to where the sfunc is actually
6269      defined, though that should be easy to add to an ffesymbol. (The
6270      token/where info available might well point to the place where the type
6271      of the sfunc is declared, especially if that precedes the place where
6272      the sfunc itself is defined, which is typically the case.)  We should
6273      put out a null pointer rather than point somewhere wrong, but I want to
6274      see how it works at this point.  */
6275
6276   input_filename = ffesymbol_where_filename (s);
6277   lineno = ffesymbol_where_filelinenum (s);
6278
6279   /* Pretransform the expression so any newly discovered things belong to the
6280      outer program unit, not to the statement function. */
6281
6282   ffecom_expr_transform_ (expr);
6283
6284   /* Make sure no recursive invocation of this fn (a specific case of failing
6285      to pretransform an sfunc's expression, i.e. where its expression
6286      references another untransformed sfunc) happens. */
6287
6288   assert (!recurse);
6289   recurse = TRUE;
6290
6291   yes = suspend_momentary ();
6292
6293   push_f_function_context ();
6294
6295   if (charfunc)
6296     type = void_type_node;
6297   else
6298     {
6299       type = ffecom_tree_type[bt][kt];
6300       if (type == NULL_TREE)
6301         type = integer_type_node;       /* _sym_exec_transition reports
6302                                            error. */
6303     }
6304
6305   start_function (ffecom_get_identifier_ (ffesymbol_text (s)),
6306                   build_function_type (type, NULL_TREE),
6307                   1,            /* nested/inline */
6308                   0);           /* TREE_PUBLIC */
6309
6310   /* We don't worry about COMPLEX return values here, because this is
6311      entirely internal to our code, and gcc has the ability to return COMPLEX
6312      directly as a value.  */
6313
6314   yes = suspend_momentary ();
6315
6316   if (charfunc)
6317     {                           /* Prepend arg for where result goes. */
6318       tree type;
6319
6320       type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
6321
6322       result = ffecom_get_invented_identifier ("__g77_%s", "result");
6323
6324       ffecom_char_enhance_arg_ (&type, s);      /* Ignore returned length. */
6325
6326       type = build_pointer_type (type);
6327       result = build_decl (PARM_DECL, result, type);
6328
6329       push_parm_decl (result);
6330     }
6331   else
6332     result = NULL_TREE;         /* Not ref'd if !charfunc. */
6333
6334   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s), TRUE);
6335
6336   resume_momentary (yes);
6337
6338   store_parm_decls (0);
6339
6340   ffecom_start_compstmt ();
6341
6342   if (expr != NULL)
6343     {
6344       if (charfunc)
6345         {
6346           ffetargetCharacterSize sz = ffesymbol_size (s);
6347           tree result_length;
6348
6349           result_length = build_int_2 (sz, 0);
6350           TREE_TYPE (result_length) = ffecom_f2c_ftnlen_type_node;
6351
6352           ffecom_prepare_let_char_ (sz, expr);
6353
6354           ffecom_prepare_end ();
6355
6356           ffecom_let_char_ (result, result_length, sz, expr);
6357           expand_null_return ();
6358         }
6359       else
6360         {
6361           ffecom_prepare_expr (expr);
6362
6363           ffecom_prepare_end ();
6364
6365           expand_return (ffecom_modify (NULL_TREE,
6366                                         DECL_RESULT (current_function_decl),
6367                                         ffecom_expr (expr)));
6368         }
6369
6370       clear_momentary ();
6371     }
6372
6373   ffecom_end_compstmt ();
6374
6375   func = current_function_decl;
6376   finish_function (1);
6377
6378   pop_f_function_context ();
6379
6380   resume_momentary (yes);
6381
6382   recurse = FALSE;
6383
6384   lineno = old_lineno;
6385   input_filename = old_input_filename;
6386
6387   ffecom_nested_entry_ = NULL;
6388
6389   return func;
6390 }
6391
6392 #endif
6393
6394 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6395 static const char *
6396 ffecom_gfrt_args_ (ffecomGfrt ix)
6397 {
6398   return ffecom_gfrt_argstring_[ix];
6399 }
6400
6401 #endif
6402 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6403 static tree
6404 ffecom_gfrt_tree_ (ffecomGfrt ix)
6405 {
6406   if (ffecom_gfrt_[ix] == NULL_TREE)
6407     ffecom_make_gfrt_ (ix);
6408
6409   return ffecom_1 (ADDR_EXPR,
6410                    build_pointer_type (TREE_TYPE (ffecom_gfrt_[ix])),
6411                    ffecom_gfrt_[ix]);
6412 }
6413
6414 #endif
6415 /* Return initialize-to-zero expression for this VAR_DECL.  */
6416
6417 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6418 /* A somewhat evil way to prevent the garbage collector
6419    from collecting 'tree' structures.  */
6420 #define NUM_TRACKED_CHUNK 63
6421 static struct tree_ggc_tracker
6422 {
6423   struct tree_ggc_tracker *next;
6424   tree trees[NUM_TRACKED_CHUNK];
6425 } *tracker_head = NULL;
6426
6427 static void
6428 mark_tracker_head (void *arg)
6429 {
6430   struct tree_ggc_tracker *head;
6431   int i;
6432
6433   for (head = * (struct tree_ggc_tracker **) arg;
6434        head != NULL;
6435        head = head->next)
6436   {
6437     ggc_mark (head);
6438     for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6439       ggc_mark_tree (head->trees[i]);
6440   }
6441 }
6442
6443 void
6444 ffecom_save_tree_forever (tree t)
6445 {
6446   int i;
6447   if (tracker_head != NULL)
6448     for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6449       if (tracker_head->trees[i] == NULL)
6450         {
6451           tracker_head->trees[i] = t;
6452           return;
6453         }
6454
6455   {
6456     /* Need to allocate a new block.  */
6457     struct tree_ggc_tracker *old_head = tracker_head;
6458
6459     tracker_head = ggc_alloc (sizeof (*tracker_head));
6460     tracker_head->next = old_head;
6461     tracker_head->trees[0] = t;
6462     for (i = 1; i < NUM_TRACKED_CHUNK; i++)
6463       tracker_head->trees[i] = NULL;
6464   }
6465 }
6466
6467 static tree
6468 ffecom_init_zero_ (tree decl)
6469 {
6470   tree init;
6471   int incremental = TREE_STATIC (decl);
6472   tree type = TREE_TYPE (decl);
6473
6474   if (incremental)
6475     {
6476       make_decl_rtl (decl, NULL, TREE_PUBLIC (decl) ? 1 : 0);
6477       assemble_variable (decl, TREE_PUBLIC (decl) ? 1 : 0, 0, 1);
6478     }
6479
6480   push_momentary ();
6481
6482   if ((TREE_CODE (type) != ARRAY_TYPE)
6483       && (TREE_CODE (type) != RECORD_TYPE)
6484       && (TREE_CODE (type) != UNION_TYPE)
6485       && !incremental)
6486     init = convert (type, integer_zero_node);
6487   else if (!incremental)
6488     {
6489       int momentary = suspend_momentary ();
6490
6491       init = build (CONSTRUCTOR, type, NULL_TREE, NULL_TREE);
6492       TREE_CONSTANT (init) = 1;
6493       TREE_STATIC (init) = 1;
6494
6495       resume_momentary (momentary);
6496     }
6497   else
6498     {
6499       int momentary = suspend_momentary ();
6500
6501       assemble_zeros (int_size_in_bytes (type));
6502       init = error_mark_node;
6503
6504       resume_momentary (momentary);
6505     }
6506
6507   pop_momentary_nofree ();
6508
6509   return init;
6510 }
6511
6512 #endif
6513 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6514 static tree
6515 ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
6516                          tree *maybe_tree)
6517 {
6518   tree expr_tree;
6519   tree length_tree;
6520
6521   switch (ffebld_op (arg))
6522     {
6523     case FFEBLD_opCONTER:       /* For F90, check 0-length. */
6524       if (ffetarget_length_character1
6525           (ffebld_constant_character1
6526            (ffebld_conter (arg))) == 0)
6527         {
6528           *maybe_tree = integer_zero_node;
6529           return convert (tree_type, integer_zero_node);
6530         }
6531
6532       *maybe_tree = integer_one_node;
6533       expr_tree = build_int_2 (*ffetarget_text_character1
6534                                (ffebld_constant_character1
6535                                 (ffebld_conter (arg))),
6536                                0);
6537       TREE_TYPE (expr_tree) = tree_type;
6538       return expr_tree;
6539
6540     case FFEBLD_opSYMTER:
6541     case FFEBLD_opARRAYREF:
6542     case FFEBLD_opFUNCREF:
6543     case FFEBLD_opSUBSTR:
6544       ffecom_char_args_ (&expr_tree, &length_tree, arg);
6545
6546       if ((expr_tree == error_mark_node)
6547           || (length_tree == error_mark_node))
6548         {
6549           *maybe_tree = error_mark_node;
6550           return error_mark_node;
6551         }
6552
6553       if (integer_zerop (length_tree))
6554         {
6555           *maybe_tree = integer_zero_node;
6556           return convert (tree_type, integer_zero_node);
6557         }
6558
6559       expr_tree
6560         = ffecom_1 (INDIRECT_REF,
6561                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6562                     expr_tree);
6563       expr_tree
6564         = ffecom_2 (ARRAY_REF,
6565                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6566                     expr_tree,
6567                     integer_one_node);
6568       expr_tree = convert (tree_type, expr_tree);
6569
6570       if (TREE_CODE (length_tree) == INTEGER_CST)
6571         *maybe_tree = integer_one_node;
6572       else                      /* Must check length at run time.  */
6573         *maybe_tree
6574           = ffecom_truth_value
6575             (ffecom_2 (GT_EXPR, integer_type_node,
6576                        length_tree,
6577                        ffecom_f2c_ftnlen_zero_node));
6578       return expr_tree;
6579
6580     case FFEBLD_opPAREN:
6581     case FFEBLD_opCONVERT:
6582       if (ffeinfo_size (ffebld_info (arg)) == 0)
6583         {
6584           *maybe_tree = integer_zero_node;
6585           return convert (tree_type, integer_zero_node);
6586         }
6587       return ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6588                                       maybe_tree);
6589
6590     case FFEBLD_opCONCATENATE:
6591       {
6592         tree maybe_left;
6593         tree maybe_right;
6594         tree expr_left;
6595         tree expr_right;
6596
6597         expr_left = ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6598                                              &maybe_left);
6599         expr_right = ffecom_intrinsic_ichar_ (tree_type, ffebld_right (arg),
6600                                               &maybe_right);
6601         *maybe_tree = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
6602                                 maybe_left,
6603                                 maybe_right);
6604         expr_tree = ffecom_3 (COND_EXPR, tree_type,
6605                               maybe_left,
6606                               expr_left,
6607                               expr_right);
6608         return expr_tree;
6609       }
6610
6611     default:
6612       assert ("bad op in ICHAR" == NULL);
6613       return error_mark_node;
6614     }
6615 }
6616
6617 #endif
6618 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
6619
6620    tree length_arg;
6621    ffebld expr;
6622    length_arg = ffecom_intrinsic_len_ (expr);
6623
6624    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
6625    subexpressions by constructing the appropriate tree for the
6626    length-of-character-text argument in a calling sequence.  */
6627
6628 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6629 static tree
6630 ffecom_intrinsic_len_ (ffebld expr)
6631 {
6632   ffetargetCharacter1 val;
6633   tree length;
6634
6635   switch (ffebld_op (expr))
6636     {
6637     case FFEBLD_opCONTER:
6638       val = ffebld_constant_character1 (ffebld_conter (expr));
6639       length = build_int_2 (ffetarget_length_character1 (val), 0);
6640       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6641       break;
6642
6643     case FFEBLD_opSYMTER:
6644       {
6645         ffesymbol s = ffebld_symter (expr);
6646         tree item;
6647
6648         item = ffesymbol_hook (s).decl_tree;
6649         if (item == NULL_TREE)
6650           {
6651             s = ffecom_sym_transform_ (s);
6652             item = ffesymbol_hook (s).decl_tree;
6653           }
6654         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
6655           {
6656             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
6657               length = ffesymbol_hook (s).length_tree;
6658             else
6659               {
6660                 length = build_int_2 (ffesymbol_size (s), 0);
6661                 TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6662               }
6663           }
6664         else if (item == error_mark_node)
6665           length = error_mark_node;
6666         else                    /* FFEINFO_kindFUNCTION: */
6667           length = NULL_TREE;
6668       }
6669       break;
6670
6671     case FFEBLD_opARRAYREF:
6672       length = ffecom_intrinsic_len_ (ffebld_left (expr));
6673       break;
6674
6675     case FFEBLD_opSUBSTR:
6676       {
6677         ffebld start;
6678         ffebld end;
6679         ffebld thing = ffebld_right (expr);
6680         tree start_tree;
6681         tree end_tree;
6682
6683         assert (ffebld_op (thing) == FFEBLD_opITEM);
6684         start = ffebld_head (thing);
6685         thing = ffebld_trail (thing);
6686         assert (ffebld_trail (thing) == NULL);
6687         end = ffebld_head (thing);
6688
6689         length = ffecom_intrinsic_len_ (ffebld_left (expr));
6690
6691         if (length == error_mark_node)
6692           break;
6693
6694         if (start == NULL)
6695           {
6696             if (end == NULL)
6697               ;
6698             else
6699               {
6700                 length = convert (ffecom_f2c_ftnlen_type_node,
6701                                   ffecom_expr (end));
6702               }
6703           }
6704         else
6705           {
6706             start_tree = convert (ffecom_f2c_ftnlen_type_node,
6707                                   ffecom_expr (start));
6708
6709             if (start_tree == error_mark_node)
6710               {
6711                 length = error_mark_node;
6712                 break;
6713               }
6714
6715             if (end == NULL)
6716               {
6717                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6718                                    ffecom_f2c_ftnlen_one_node,
6719                                    ffecom_2 (MINUS_EXPR,
6720                                              ffecom_f2c_ftnlen_type_node,
6721                                              length,
6722                                              start_tree));
6723               }
6724             else
6725               {
6726                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
6727                                     ffecom_expr (end));
6728
6729                 if (end_tree == error_mark_node)
6730                   {
6731                     length = error_mark_node;
6732                     break;
6733                   }
6734
6735                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6736                                    ffecom_f2c_ftnlen_one_node,
6737                                    ffecom_2 (MINUS_EXPR,
6738                                              ffecom_f2c_ftnlen_type_node,
6739                                              end_tree, start_tree));
6740               }
6741           }
6742       }
6743       break;
6744
6745     case FFEBLD_opCONCATENATE:
6746       length
6747         = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6748                     ffecom_intrinsic_len_ (ffebld_left (expr)),
6749                     ffecom_intrinsic_len_ (ffebld_right (expr)));
6750       break;
6751
6752     case FFEBLD_opFUNCREF:
6753     case FFEBLD_opCONVERT:
6754       length = build_int_2 (ffebld_size (expr), 0);
6755       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6756       break;
6757
6758     default:
6759       assert ("bad op for single char arg expr" == NULL);
6760       length = ffecom_f2c_ftnlen_zero_node;
6761       break;
6762     }
6763
6764   assert (length != NULL_TREE);
6765
6766   return length;
6767 }
6768
6769 #endif
6770 /* Handle CHARACTER assignments.
6771
6772    Generates code to do the assignment.  Used by ordinary assignment
6773    statement handler ffecom_let_stmt and by statement-function
6774    handler to generate code for a statement function.  */
6775
6776 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6777 static void
6778 ffecom_let_char_ (tree dest_tree, tree dest_length,
6779                   ffetargetCharacterSize dest_size, ffebld source)
6780 {
6781   ffecomConcatList_ catlist;
6782   tree source_length;
6783   tree source_tree;
6784   tree expr_tree;
6785
6786   if ((dest_tree == error_mark_node)
6787       || (dest_length == error_mark_node))
6788     return;
6789
6790   assert (dest_tree != NULL_TREE);
6791   assert (dest_length != NULL_TREE);
6792
6793   /* Source might be an opCONVERT, which just means it is a different size
6794      than the destination.  Since the underlying implementation here handles
6795      that (directly or via the s_copy or s_cat run-time-library functions),
6796      we don't need the "convenience" of an opCONVERT that tells us to
6797      truncate or blank-pad, particularly since the resulting implementation
6798      would probably be slower than otherwise. */
6799
6800   while (ffebld_op (source) == FFEBLD_opCONVERT)
6801     source = ffebld_left (source);
6802
6803   catlist = ffecom_concat_list_new_ (source, dest_size);
6804   switch (ffecom_concat_list_count_ (catlist))
6805     {
6806     case 0:                     /* Shouldn't happen, but in case it does... */
6807       ffecom_concat_list_kill_ (catlist);
6808       source_tree = null_pointer_node;
6809       source_length = ffecom_f2c_ftnlen_zero_node;
6810       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6811       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6812       TREE_CHAIN (TREE_CHAIN (expr_tree))
6813         = build_tree_list (NULL_TREE, dest_length);
6814       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6815         = build_tree_list (NULL_TREE, source_length);
6816
6817       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6818       TREE_SIDE_EFFECTS (expr_tree) = 1;
6819
6820       expand_expr_stmt (expr_tree);
6821
6822       return;
6823
6824     case 1:                     /* The (fairly) easy case. */
6825       ffecom_char_args_ (&source_tree, &source_length,
6826                          ffecom_concat_list_expr_ (catlist, 0));
6827       ffecom_concat_list_kill_ (catlist);
6828       assert (source_tree != NULL_TREE);
6829       assert (source_length != NULL_TREE);
6830
6831       if ((source_tree == error_mark_node)
6832           || (source_length == error_mark_node))
6833         return;
6834
6835       if (dest_size == 1)
6836         {
6837           dest_tree
6838             = ffecom_1 (INDIRECT_REF,
6839                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6840                                                       (dest_tree))),
6841                         dest_tree);
6842           dest_tree
6843             = ffecom_2 (ARRAY_REF,
6844                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6845                                                       (dest_tree))),
6846                         dest_tree,
6847                         integer_one_node);
6848           source_tree
6849             = ffecom_1 (INDIRECT_REF,
6850                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6851                                                       (source_tree))),
6852                         source_tree);
6853           source_tree
6854             = ffecom_2 (ARRAY_REF,
6855                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6856                                                       (source_tree))),
6857                         source_tree,
6858                         integer_one_node);
6859
6860           expr_tree = ffecom_modify (void_type_node, dest_tree, source_tree);
6861
6862           expand_expr_stmt (expr_tree);
6863
6864           return;
6865         }
6866
6867       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6868       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6869       TREE_CHAIN (TREE_CHAIN (expr_tree))
6870         = build_tree_list (NULL_TREE, dest_length);
6871       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6872         = build_tree_list (NULL_TREE, source_length);
6873
6874       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6875       TREE_SIDE_EFFECTS (expr_tree) = 1;
6876
6877       expand_expr_stmt (expr_tree);
6878
6879       return;
6880
6881     default:                    /* Must actually concatenate things. */
6882       break;
6883     }
6884
6885   /* Heavy-duty concatenation. */
6886
6887   {
6888     int count = ffecom_concat_list_count_ (catlist);
6889     int i;
6890     tree lengths;
6891     tree items;
6892     tree length_array;
6893     tree item_array;
6894     tree citem;
6895     tree clength;
6896
6897 #ifdef HOHO
6898     length_array
6899       = lengths
6900       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
6901                              FFETARGET_charactersizeNONE, count, TRUE);
6902     item_array = items = ffecom_push_tempvar (ffecom_f2c_address_type_node,
6903                                               FFETARGET_charactersizeNONE,
6904                                               count, TRUE);
6905 #else
6906     {
6907       tree hook;
6908
6909       hook = ffebld_nonter_hook (source);
6910       assert (hook);
6911       assert (TREE_CODE (hook) == TREE_VEC);
6912       assert (TREE_VEC_LENGTH (hook) == 2);
6913       length_array = lengths = TREE_VEC_ELT (hook, 0);
6914       item_array = items = TREE_VEC_ELT (hook, 1);
6915     }
6916 #endif
6917
6918     for (i = 0; i < count; ++i)
6919       {
6920         ffecom_char_args_ (&citem, &clength,
6921                            ffecom_concat_list_expr_ (catlist, i));
6922         if ((citem == error_mark_node)
6923             || (clength == error_mark_node))
6924           {
6925             ffecom_concat_list_kill_ (catlist);
6926             return;
6927           }
6928
6929         items
6930           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
6931                       ffecom_modify (void_type_node,
6932                                      ffecom_2 (ARRAY_REF,
6933                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
6934                                                item_array,
6935                                                build_int_2 (i, 0)),
6936                                      citem),
6937                       items);
6938         lengths
6939           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
6940                       ffecom_modify (void_type_node,
6941                                      ffecom_2 (ARRAY_REF,
6942                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
6943                                                length_array,
6944                                                build_int_2 (i, 0)),
6945                                      clength),
6946                       lengths);
6947       }
6948
6949     expr_tree = build_tree_list (NULL_TREE, dest_tree);
6950     TREE_CHAIN (expr_tree)
6951       = build_tree_list (NULL_TREE,
6952                          ffecom_1 (ADDR_EXPR,
6953                                    build_pointer_type (TREE_TYPE (items)),
6954                                    items));
6955     TREE_CHAIN (TREE_CHAIN (expr_tree))
6956       = build_tree_list (NULL_TREE,
6957                          ffecom_1 (ADDR_EXPR,
6958                                    build_pointer_type (TREE_TYPE (lengths)),
6959                                    lengths));
6960     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6961       = build_tree_list
6962         (NULL_TREE,
6963          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
6964                    convert (ffecom_f2c_ftnlen_type_node,
6965                             build_int_2 (count, 0))));
6966     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))))
6967       = build_tree_list (NULL_TREE, dest_length);
6968
6969     expr_tree = ffecom_call_gfrt (FFECOM_gfrtCAT, expr_tree, NULL_TREE);
6970     TREE_SIDE_EFFECTS (expr_tree) = 1;
6971
6972     expand_expr_stmt (expr_tree);
6973   }
6974
6975   ffecom_concat_list_kill_ (catlist);
6976 }
6977
6978 #endif
6979 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
6980
6981    ffecomGfrt ix;
6982    ffecom_make_gfrt_(ix);
6983
6984    Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
6985    for the indicated run-time routine (ix).  */
6986
6987 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6988 static void
6989 ffecom_make_gfrt_ (ffecomGfrt ix)
6990 {
6991   tree t;
6992   tree ttype;
6993
6994   switch (ffecom_gfrt_type_[ix])
6995     {
6996     case FFECOM_rttypeVOID_:
6997       ttype = void_type_node;
6998       break;
6999
7000     case FFECOM_rttypeVOIDSTAR_:
7001       ttype = TREE_TYPE (null_pointer_node);    /* `void *'. */
7002       break;
7003
7004     case FFECOM_rttypeFTNINT_:
7005       ttype = ffecom_f2c_ftnint_type_node;
7006       break;
7007
7008     case FFECOM_rttypeINTEGER_:
7009       ttype = ffecom_f2c_integer_type_node;
7010       break;
7011
7012     case FFECOM_rttypeLONGINT_:
7013       ttype = ffecom_f2c_longint_type_node;
7014       break;
7015
7016     case FFECOM_rttypeLOGICAL_:
7017       ttype = ffecom_f2c_logical_type_node;
7018       break;
7019
7020     case FFECOM_rttypeREAL_F2C_:
7021       ttype = double_type_node;
7022       break;
7023
7024     case FFECOM_rttypeREAL_GNU_:
7025       ttype = float_type_node;
7026       break;
7027
7028     case FFECOM_rttypeCOMPLEX_F2C_:
7029       ttype = void_type_node;
7030       break;
7031
7032     case FFECOM_rttypeCOMPLEX_GNU_:
7033       ttype = ffecom_f2c_complex_type_node;
7034       break;
7035
7036     case FFECOM_rttypeDOUBLE_:
7037       ttype = double_type_node;
7038       break;
7039
7040     case FFECOM_rttypeDOUBLEREAL_:
7041       ttype = ffecom_f2c_doublereal_type_node;
7042       break;
7043
7044     case FFECOM_rttypeDBLCMPLX_F2C_:
7045       ttype = void_type_node;
7046       break;
7047
7048     case FFECOM_rttypeDBLCMPLX_GNU_:
7049       ttype = ffecom_f2c_doublecomplex_type_node;
7050       break;
7051
7052     case FFECOM_rttypeCHARACTER_:
7053       ttype = void_type_node;
7054       break;
7055
7056     default:
7057       ttype = NULL;
7058       assert ("bad rttype" == NULL);
7059       break;
7060     }
7061
7062   ttype = build_function_type (ttype, NULL_TREE);
7063   t = build_decl (FUNCTION_DECL,
7064                   get_identifier (ffecom_gfrt_name_[ix]),
7065                   ttype);
7066   DECL_EXTERNAL (t) = 1;
7067   TREE_PUBLIC (t) = 1;
7068   TREE_THIS_VOLATILE (t) = ffecom_gfrt_volatile_[ix] ? 1 : 0;
7069
7070   t = start_decl (t, TRUE);
7071
7072   finish_decl (t, NULL_TREE, TRUE);
7073
7074   ffecom_gfrt_[ix] = t;
7075 }
7076
7077 #endif
7078 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group.  */
7079
7080 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7081 static void
7082 ffecom_member_phase1_ (ffestorag mst UNUSED, ffestorag st)
7083 {
7084   ffesymbol s = ffestorag_symbol (st);
7085
7086   if (ffesymbol_namelisted (s))
7087     ffecom_member_namelisted_ = TRUE;
7088 }
7089
7090 #endif
7091 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group.  Declare
7092    the member so debugger will see it.  Otherwise nobody should be
7093    referencing the member.  */
7094
7095 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7096 static void
7097 ffecom_member_phase2_ (ffestorag mst, ffestorag st)
7098 {
7099   ffesymbol s;
7100   tree t;
7101   tree mt;
7102   tree type;
7103
7104   if ((mst == NULL)
7105       || ((mt = ffestorag_hook (mst)) == NULL)
7106       || (mt == error_mark_node))
7107     return;
7108
7109   if ((st == NULL)
7110       || ((s = ffestorag_symbol (st)) == NULL))
7111     return;
7112
7113   type = ffecom_type_localvar_ (s,
7114                                 ffesymbol_basictype (s),
7115                                 ffesymbol_kindtype (s));
7116   if (type == error_mark_node)
7117     return;
7118
7119   t = build_decl (VAR_DECL,
7120                   ffecom_get_identifier_ (ffesymbol_text (s)),
7121                   type);
7122
7123   TREE_STATIC (t) = TREE_STATIC (mt);
7124   DECL_INITIAL (t) = NULL_TREE;
7125   TREE_ASM_WRITTEN (t) = 1;
7126
7127   DECL_RTL (t)
7128     = gen_rtx (MEM, TYPE_MODE (type),
7129                plus_constant (XEXP (DECL_RTL (mt), 0),
7130                               ffestorag_modulo (mst)
7131                               + ffestorag_offset (st)
7132                               - ffestorag_offset (mst)));
7133
7134   t = start_decl (t, FALSE);
7135
7136   finish_decl (t, NULL_TREE, FALSE);
7137 }
7138
7139 #endif
7140 /* Prepare source expression for assignment into a destination perhaps known
7141    to be of a specific size.  */
7142
7143 static void
7144 ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size, ffebld source)
7145 {
7146   ffecomConcatList_ catlist;
7147   int count;
7148   int i;
7149   tree ltmp;
7150   tree itmp;
7151   tree tempvar = NULL_TREE;
7152
7153   while (ffebld_op (source) == FFEBLD_opCONVERT)
7154     source = ffebld_left (source);
7155
7156   catlist = ffecom_concat_list_new_ (source, dest_size);
7157   count = ffecom_concat_list_count_ (catlist);
7158
7159   if (count >= 2)
7160     {
7161       ltmp
7162         = ffecom_make_tempvar ("let_char_len", ffecom_f2c_ftnlen_type_node,
7163                                FFETARGET_charactersizeNONE, count);
7164       itmp
7165         = ffecom_make_tempvar ("let_char_item", ffecom_f2c_address_type_node,
7166                                FFETARGET_charactersizeNONE, count);
7167
7168       tempvar = make_tree_vec (2);
7169       TREE_VEC_ELT (tempvar, 0) = ltmp;
7170       TREE_VEC_ELT (tempvar, 1) = itmp;
7171     }
7172
7173   for (i = 0; i < count; ++i)
7174     ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist, i));
7175
7176   ffecom_concat_list_kill_ (catlist);
7177
7178   if (tempvar)
7179     {
7180       ffebld_nonter_set_hook (source, tempvar);
7181       current_binding_level->prep_state = 1;
7182     }
7183 }
7184
7185 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
7186
7187    Ignores STAR (alternate-return) dummies.  All other get exec-transitioned
7188    (which generates their trees) and then their trees get push_parm_decl'd.
7189
7190    The second arg is TRUE if the dummies are for a statement function, in
7191    which case lengths are not pushed for character arguments (since they are
7192    always known by both the caller and the callee, though the code allows
7193    for someday permitting CHAR*(*) stmtfunc dummies).  */
7194
7195 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7196 static void
7197 ffecom_push_dummy_decls_ (ffebld dummy_list, bool stmtfunc)
7198 {
7199   ffebld dummy;
7200   ffebld dumlist;
7201   ffesymbol s;
7202   tree parm;
7203
7204   ffecom_transform_only_dummies_ = TRUE;
7205
7206   /* First push the parms corresponding to actual dummy "contents".  */
7207
7208   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7209     {
7210       dummy = ffebld_head (dumlist);
7211       switch (ffebld_op (dummy))
7212         {
7213         case FFEBLD_opSTAR:
7214         case FFEBLD_opANY:
7215           continue;             /* Forget alternate returns. */
7216
7217         default:
7218           break;
7219         }
7220       assert (ffebld_op (dummy) == FFEBLD_opSYMTER);
7221       s = ffebld_symter (dummy);
7222       parm = ffesymbol_hook (s).decl_tree;
7223       if (parm == NULL_TREE)
7224         {
7225           s = ffecom_sym_transform_ (s);
7226           parm = ffesymbol_hook (s).decl_tree;
7227           assert (parm != NULL_TREE);
7228         }
7229       if (parm != error_mark_node)
7230         push_parm_decl (parm);
7231     }
7232
7233   /* Then, for CHARACTER dummies, push the parms giving their lengths.  */
7234
7235   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7236     {
7237       dummy = ffebld_head (dumlist);
7238       switch (ffebld_op (dummy))
7239         {
7240         case FFEBLD_opSTAR:
7241         case FFEBLD_opANY:
7242           continue;             /* Forget alternate returns, they mean
7243                                    NOTHING! */
7244
7245         default:
7246           break;
7247         }
7248       s = ffebld_symter (dummy);
7249       if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
7250         continue;               /* Only looking for CHARACTER arguments. */
7251       if (stmtfunc && (ffesymbol_size (s) != FFETARGET_charactersizeNONE))
7252         continue;               /* Stmtfunc arg with known size needs no
7253                                    length param. */
7254       if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
7255         continue;               /* Only looking for variables and arrays. */
7256       parm = ffesymbol_hook (s).length_tree;
7257       assert (parm != NULL_TREE);
7258       if (parm != error_mark_node)
7259         push_parm_decl (parm);
7260     }
7261
7262   ffecom_transform_only_dummies_ = FALSE;
7263 }
7264
7265 #endif
7266 /* ffecom_start_progunit_ -- Beginning of program unit
7267
7268    Does GNU back end stuff necessary to teach it about the start of its
7269    equivalent of a Fortran program unit.  */
7270
7271 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7272 static void
7273 ffecom_start_progunit_ ()
7274 {
7275   ffesymbol fn = ffecom_primary_entry_;
7276   ffebld arglist;
7277   tree id;                      /* Identifier (name) of function. */
7278   tree type;                    /* Type of function. */
7279   tree result;                  /* Result of function. */
7280   ffeinfoBasictype bt;
7281   ffeinfoKindtype kt;
7282   ffeglobal g;
7283   ffeglobalType gt;
7284   ffeglobalType egt = FFEGLOBAL_type;
7285   bool charfunc;
7286   bool cmplxfunc;
7287   bool altentries = (ffecom_num_entrypoints_ != 0);
7288   bool multi
7289   = altentries
7290   && (ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
7291   && (ffecom_master_bt_ == FFEINFO_basictypeNONE);
7292   bool main_program = FALSE;
7293   int old_lineno = lineno;
7294   const char *old_input_filename = input_filename;
7295   int yes;
7296
7297   assert (fn != NULL);
7298   assert (ffesymbol_hook (fn).decl_tree == NULL_TREE);
7299
7300   input_filename = ffesymbol_where_filename (fn);
7301   lineno = ffesymbol_where_filelinenum (fn);
7302
7303   /* c-parse.y indeed does call suspend_momentary and not only ignores the
7304      return value, but also never calls resume_momentary, when starting an
7305      outer function (see "fndef:", "setspecs:", and so on).  So g77 does the
7306      same thing.  It shouldn't be a problem since start_function calls
7307      temporary_allocation, but it might be necessary.  If it causes a problem
7308      here, then maybe there's a bug lurking in gcc.  NOTE: This identical
7309      comment appears twice in thist file.  */
7310
7311   suspend_momentary ();
7312
7313   switch (ffecom_primary_entry_kind_)
7314     {
7315     case FFEINFO_kindPROGRAM:
7316       main_program = TRUE;
7317       gt = FFEGLOBAL_typeMAIN;
7318       bt = FFEINFO_basictypeNONE;
7319       kt = FFEINFO_kindtypeNONE;
7320       type = ffecom_tree_fun_type_void;
7321       charfunc = FALSE;
7322       cmplxfunc = FALSE;
7323       break;
7324
7325     case FFEINFO_kindBLOCKDATA:
7326       gt = FFEGLOBAL_typeBDATA;
7327       bt = FFEINFO_basictypeNONE;
7328       kt = FFEINFO_kindtypeNONE;
7329       type = ffecom_tree_fun_type_void;
7330       charfunc = FALSE;
7331       cmplxfunc = FALSE;
7332       break;
7333
7334     case FFEINFO_kindFUNCTION:
7335       gt = FFEGLOBAL_typeFUNC;
7336       egt = FFEGLOBAL_typeEXT;
7337       bt = ffesymbol_basictype (fn);
7338       kt = ffesymbol_kindtype (fn);
7339       if (bt == FFEINFO_basictypeNONE)
7340         {
7341           ffeimplic_establish_symbol (fn);
7342           if (ffesymbol_funcresult (fn) != NULL)
7343             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
7344           bt = ffesymbol_basictype (fn);
7345           kt = ffesymbol_kindtype (fn);
7346         }
7347
7348       if (multi)
7349         charfunc = cmplxfunc = FALSE;
7350       else if (bt == FFEINFO_basictypeCHARACTER)
7351         charfunc = TRUE, cmplxfunc = FALSE;
7352       else if ((bt == FFEINFO_basictypeCOMPLEX)
7353                && ffesymbol_is_f2c (fn)
7354                && !altentries)
7355         charfunc = FALSE, cmplxfunc = TRUE;
7356       else
7357         charfunc = cmplxfunc = FALSE;
7358
7359       if (multi || charfunc)
7360         type = ffecom_tree_fun_type_void;
7361       else if (ffesymbol_is_f2c (fn) && !altentries)
7362         type = ffecom_tree_fun_type[bt][kt];
7363       else
7364         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
7365
7366       if ((type == NULL_TREE)
7367           || (TREE_TYPE (type) == NULL_TREE))
7368         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
7369       break;
7370
7371     case FFEINFO_kindSUBROUTINE:
7372       gt = FFEGLOBAL_typeSUBR;
7373       egt = FFEGLOBAL_typeEXT;
7374       bt = FFEINFO_basictypeNONE;
7375       kt = FFEINFO_kindtypeNONE;
7376       if (ffecom_is_altreturning_)
7377         type = ffecom_tree_subr_type;
7378       else
7379         type = ffecom_tree_fun_type_void;
7380       charfunc = FALSE;
7381       cmplxfunc = FALSE;
7382       break;
7383
7384     default:
7385       assert ("say what??" == NULL);
7386       /* Fall through. */
7387     case FFEINFO_kindANY:
7388       gt = FFEGLOBAL_typeANY;
7389       bt = FFEINFO_basictypeNONE;
7390       kt = FFEINFO_kindtypeNONE;
7391       type = error_mark_node;
7392       charfunc = FALSE;
7393       cmplxfunc = FALSE;
7394       break;
7395     }
7396
7397   if (altentries)
7398     {
7399       id = ffecom_get_invented_identifier ("__g77_masterfun_%s",
7400                                            ffesymbol_text (fn));
7401     }
7402 #if FFETARGET_isENFORCED_MAIN
7403   else if (main_program)
7404     id = get_identifier (FFETARGET_nameENFORCED_MAIN_NAME);
7405 #endif
7406   else
7407     id = ffecom_get_external_identifier_ (fn);
7408
7409   start_function (id,
7410                   type,
7411                   0,            /* nested/inline */
7412                   !altentries); /* TREE_PUBLIC */
7413
7414   TREE_USED (current_function_decl) = 1;        /* Avoid spurious warning if altentries. */
7415
7416   if (!altentries
7417       && ((g = ffesymbol_global (fn)) != NULL)
7418       && ((ffeglobal_type (g) == gt)
7419           || (ffeglobal_type (g) == egt)))
7420     {
7421       ffeglobal_set_hook (g, current_function_decl);
7422     }
7423
7424   yes = suspend_momentary ();
7425
7426   /* Arg handling needs exec-transitioned ffesymbols to work with.  But
7427      exec-transitioning needs current_function_decl to be filled in.  So we
7428      do these things in two phases. */
7429
7430   if (altentries)
7431     {                           /* 1st arg identifies which entrypoint. */
7432       ffecom_which_entrypoint_decl_
7433         = build_decl (PARM_DECL,
7434                       ffecom_get_invented_identifier ("__g77_%s",
7435                                                       "which_entrypoint"),
7436                       integer_type_node);
7437       push_parm_decl (ffecom_which_entrypoint_decl_);
7438     }
7439
7440   if (charfunc
7441       || cmplxfunc
7442       || multi)
7443     {                           /* Arg for result (return value). */
7444       tree type;
7445       tree length;
7446
7447       if (charfunc)
7448         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
7449       else if (cmplxfunc)
7450         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
7451       else
7452         type = ffecom_multi_type_node_;
7453
7454       result = ffecom_get_invented_identifier ("__g77_%s", "result");
7455
7456       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
7457
7458       if (charfunc)
7459         length = ffecom_char_enhance_arg_ (&type, fn);
7460       else
7461         length = NULL_TREE;     /* Not ref'd if !charfunc. */
7462
7463       type = build_pointer_type (type);
7464       result = build_decl (PARM_DECL, result, type);
7465
7466       push_parm_decl (result);
7467       if (multi)
7468         ffecom_multi_retval_ = result;
7469       else
7470         ffecom_func_result_ = result;
7471
7472       if (charfunc)
7473         {
7474           push_parm_decl (length);
7475           ffecom_func_length_ = length;
7476         }
7477     }
7478
7479   if (ffecom_primary_entry_is_proc_)
7480     {
7481       if (altentries)
7482         arglist = ffecom_master_arglist_;
7483       else
7484         arglist = ffesymbol_dummyargs (fn);
7485       ffecom_push_dummy_decls_ (arglist, FALSE);
7486     }
7487
7488   resume_momentary (yes);
7489
7490   if (TREE_CODE (current_function_decl) != ERROR_MARK)
7491     store_parm_decls (main_program ? 1 : 0);
7492
7493   ffecom_start_compstmt ();
7494   /* Disallow temp vars at this level.  */
7495   current_binding_level->prep_state = 2;
7496
7497   lineno = old_lineno;
7498   input_filename = old_input_filename;
7499
7500   /* This handles any symbols still untransformed, in case -g specified.
7501      This used to be done in ffecom_finish_progunit, but it turns out to
7502      be necessary to do it here so that statement functions are
7503      expanded before code.  But don't bother for BLOCK DATA.  */
7504
7505   if (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
7506     ffesymbol_drive (ffecom_finish_symbol_transform_);
7507 }
7508
7509 #endif
7510 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
7511
7512    ffesymbol s;
7513    ffecom_sym_transform_(s);
7514
7515    The ffesymbol_hook info for s is updated with appropriate backend info
7516    on the symbol.  */
7517
7518 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7519 static ffesymbol
7520 ffecom_sym_transform_ (ffesymbol s)
7521 {
7522   tree t;                       /* Transformed thingy. */
7523   tree tlen;                    /* Length if CHAR*(*). */
7524   bool addr;                    /* Is t the address of the thingy? */
7525   ffeinfoBasictype bt;
7526   ffeinfoKindtype kt;
7527   ffeglobal g;
7528   int yes;
7529   int old_lineno = lineno;
7530   const char *old_input_filename = input_filename;
7531
7532   /* Must ensure special ASSIGN variables are declared at top of outermost
7533      block, else they'll end up in the innermost block when their first
7534      ASSIGN is seen, which leaves them out of scope when they're the
7535      subject of a GOTO or I/O statement.
7536
7537      We make this variable even if -fugly-assign.  Just let it go unused,
7538      in case it turns out there are cases where we really want to use this
7539      variable anyway (e.g. ASSIGN to INTEGER*2 variable).  */
7540
7541   if (! ffecom_transform_only_dummies_
7542       && ffesymbol_assigned (s)
7543       && ! ffesymbol_hook (s).assign_tree)
7544     s = ffecom_sym_transform_assign_ (s);
7545
7546   if (ffesymbol_sfdummyparent (s) == NULL)
7547     {
7548       input_filename = ffesymbol_where_filename (s);
7549       lineno = ffesymbol_where_filelinenum (s);
7550     }
7551   else
7552     {
7553       ffesymbol sf = ffesymbol_sfdummyparent (s);
7554
7555       input_filename = ffesymbol_where_filename (sf);
7556       lineno = ffesymbol_where_filelinenum (sf);
7557     }
7558
7559   bt = ffeinfo_basictype (ffebld_info (s));
7560   kt = ffeinfo_kindtype (ffebld_info (s));
7561
7562   t = NULL_TREE;
7563   tlen = NULL_TREE;
7564   addr = FALSE;
7565
7566   switch (ffesymbol_kind (s))
7567     {
7568     case FFEINFO_kindNONE:
7569       switch (ffesymbol_where (s))
7570         {
7571         case FFEINFO_whereDUMMY:        /* Subroutine or function. */
7572           assert (ffecom_transform_only_dummies_);
7573
7574           /* Before 0.4, this could be ENTITY/DUMMY, but see
7575              ffestu_sym_end_transition -- no longer true (in particular, if
7576              it could be an ENTITY, it _will_ be made one, so that
7577              possibility won't come through here).  So we never make length
7578              arg for CHARACTER type.  */
7579
7580           t = build_decl (PARM_DECL,
7581                           ffecom_get_identifier_ (ffesymbol_text (s)),
7582                           ffecom_tree_ptr_to_subr_type);
7583 #if BUILT_FOR_270
7584           DECL_ARTIFICIAL (t) = 1;
7585 #endif
7586           addr = TRUE;
7587           break;
7588
7589         case FFEINFO_whereGLOBAL:       /* Subroutine or function. */
7590           assert (!ffecom_transform_only_dummies_);
7591
7592           if (((g = ffesymbol_global (s)) != NULL)
7593               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7594                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7595                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
7596               && (ffeglobal_hook (g) != NULL_TREE)
7597               && ffe_is_globals ())
7598             {
7599               t = ffeglobal_hook (g);
7600               break;
7601             }
7602
7603           t = build_decl (FUNCTION_DECL,
7604                           ffecom_get_external_identifier_ (s),
7605                           ffecom_tree_subr_type);       /* Assume subr. */
7606           DECL_EXTERNAL (t) = 1;
7607           TREE_PUBLIC (t) = 1;
7608
7609           t = start_decl (t, FALSE);
7610           finish_decl (t, NULL_TREE, FALSE);
7611
7612           if ((g != NULL)
7613               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7614                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7615                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
7616             ffeglobal_set_hook (g, t);
7617
7618           ffecom_save_tree_forever (t);
7619
7620           break;
7621
7622         default:
7623           assert ("NONE where unexpected" == NULL);
7624           /* Fall through. */
7625         case FFEINFO_whereANY:
7626           break;
7627         }
7628       break;
7629
7630     case FFEINFO_kindENTITY:
7631       switch (ffeinfo_where (ffesymbol_info (s)))
7632         {
7633
7634         case FFEINFO_whereCONSTANT:
7635           /* ~~Debugging info needed? */
7636           assert (!ffecom_transform_only_dummies_);
7637           t = error_mark_node;  /* Shouldn't ever see this in expr. */
7638           break;
7639
7640         case FFEINFO_whereLOCAL:
7641           assert (!ffecom_transform_only_dummies_);
7642
7643           {
7644             ffestorag st = ffesymbol_storage (s);
7645             tree type;
7646
7647             if ((st != NULL)
7648                 && (ffestorag_size (st) == 0))
7649               {
7650                 t = error_mark_node;
7651                 break;
7652               }
7653
7654             yes = suspend_momentary ();
7655             type = ffecom_type_localvar_ (s, bt, kt);
7656             resume_momentary (yes);
7657
7658             if (type == error_mark_node)
7659               {
7660                 t = error_mark_node;
7661                 break;
7662               }
7663
7664             if ((st != NULL)
7665                 && (ffestorag_parent (st) != NULL))
7666               {                 /* Child of EQUIVALENCE parent. */
7667                 ffestorag est;
7668                 tree et;
7669                 int yes;
7670                 ffetargetOffset offset;
7671
7672                 est = ffestorag_parent (st);
7673                 ffecom_transform_equiv_ (est);
7674
7675                 et = ffestorag_hook (est);
7676                 assert (et != NULL_TREE);
7677
7678                 if (! TREE_STATIC (et))
7679                   put_var_into_stack (et);
7680
7681                 yes = suspend_momentary ();
7682
7683                 offset = ffestorag_modulo (est)
7684                   + ffestorag_offset (ffesymbol_storage (s))
7685                   - ffestorag_offset (est);
7686
7687                 ffecom_debug_kludge_ (et, "EQUIVALENCE", s, type, offset);
7688
7689                 /* (t_type *) (((char *) &et) + offset) */
7690
7691                 t = convert (string_type_node,  /* (char *) */
7692                              ffecom_1 (ADDR_EXPR,
7693                                        build_pointer_type (TREE_TYPE (et)),
7694                                        et));
7695                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
7696                               t,
7697                               build_int_2 (offset, 0));
7698                 t = convert (build_pointer_type (type),
7699                              t);
7700                 TREE_CONSTANT (t) = staticp (et);
7701
7702                 addr = TRUE;
7703
7704                 resume_momentary (yes);
7705               }
7706             else
7707               {
7708                 tree initexpr;
7709                 bool init = ffesymbol_is_init (s);
7710
7711                 yes = suspend_momentary ();
7712
7713                 t = build_decl (VAR_DECL,
7714                                 ffecom_get_identifier_ (ffesymbol_text (s)),
7715                                 type);
7716
7717                 if (init
7718                     || ffesymbol_namelisted (s)
7719 #ifdef FFECOM_sizeMAXSTACKITEM
7720                     || ((st != NULL)
7721                         && (ffestorag_size (st) > FFECOM_sizeMAXSTACKITEM))
7722 #endif
7723                     || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
7724                         && (ffecom_primary_entry_kind_
7725                             != FFEINFO_kindBLOCKDATA)
7726                         && (ffesymbol_is_save (s) || ffe_is_saveall ())))
7727                   TREE_STATIC (t) = !ffesymbol_attr (s, FFESYMBOL_attrADJUSTABLE);
7728                 else
7729                   TREE_STATIC (t) = 0;  /* No need to make static. */
7730
7731                 if (init || ffe_is_init_local_zero ())
7732                   DECL_INITIAL (t) = error_mark_node;
7733
7734                 /* Keep -Wunused from complaining about var if it
7735                    is used as sfunc arg or DATA implied-DO.  */
7736                 if (ffesymbol_attrs (s) & FFESYMBOL_attrsSFARG)
7737                   DECL_IN_SYSTEM_HEADER (t) = 1;
7738
7739                 t = start_decl (t, FALSE);
7740
7741                 if (init)
7742                   {
7743                     if (ffesymbol_init (s) != NULL)
7744                       initexpr = ffecom_expr (ffesymbol_init (s));
7745                     else
7746                       initexpr = ffecom_init_zero_ (t);
7747                   }
7748                 else if (ffe_is_init_local_zero ())
7749                   initexpr = ffecom_init_zero_ (t);
7750                 else
7751                   initexpr = NULL_TREE; /* Not ref'd if !init. */
7752
7753                 finish_decl (t, initexpr, FALSE);
7754
7755                 if (st != NULL && DECL_SIZE (t) != error_mark_node)
7756                   {
7757                     assert (TREE_CODE (DECL_SIZE_UNIT (t)) == INTEGER_CST);
7758                     assert (0 == compare_tree_int (DECL_SIZE_UNIT (t),
7759                                                    ffestorag_size (st)));
7760                   }
7761
7762                 resume_momentary (yes);
7763               }
7764           }
7765           break;
7766
7767         case FFEINFO_whereRESULT:
7768           assert (!ffecom_transform_only_dummies_);
7769
7770           if (bt == FFEINFO_basictypeCHARACTER)
7771             {                   /* Result is already in list of dummies, use
7772                                    it (& length). */
7773               t = ffecom_func_result_;
7774               tlen = ffecom_func_length_;
7775               addr = TRUE;
7776               break;
7777             }
7778           if ((ffecom_num_entrypoints_ == 0)
7779               && (bt == FFEINFO_basictypeCOMPLEX)
7780               && (ffesymbol_is_f2c (ffecom_primary_entry_)))
7781             {                   /* Result is already in list of dummies, use
7782                                    it. */
7783               t = ffecom_func_result_;
7784               addr = TRUE;
7785               break;
7786             }
7787           if (ffecom_func_result_ != NULL_TREE)
7788             {
7789               t = ffecom_func_result_;
7790               break;
7791             }
7792           if ((ffecom_num_entrypoints_ != 0)
7793               && (ffecom_master_bt_ == FFEINFO_basictypeNONE))
7794             {
7795               yes = suspend_momentary ();
7796
7797               assert (ffecom_multi_retval_ != NULL_TREE);
7798               t = ffecom_1 (INDIRECT_REF, ffecom_multi_type_node_,
7799                             ffecom_multi_retval_);
7800               t = ffecom_2 (COMPONENT_REF, ffecom_tree_type[bt][kt],
7801                             t, ffecom_multi_fields_[bt][kt]);
7802
7803               resume_momentary (yes);
7804               break;
7805             }
7806
7807           yes = suspend_momentary ();
7808
7809           t = build_decl (VAR_DECL,
7810                           ffecom_get_identifier_ (ffesymbol_text (s)),
7811                           ffecom_tree_type[bt][kt]);
7812           TREE_STATIC (t) = 0;  /* Put result on stack. */
7813           t = start_decl (t, FALSE);
7814           finish_decl (t, NULL_TREE, FALSE);
7815
7816           ffecom_func_result_ = t;
7817
7818           resume_momentary (yes);
7819           break;
7820
7821         case FFEINFO_whereDUMMY:
7822           {
7823             tree type;
7824             ffebld dl;
7825             ffebld dim;
7826             tree low;
7827             tree high;
7828             tree old_sizes;
7829             bool adjustable = FALSE;    /* Conditionally adjustable? */
7830
7831             type = ffecom_tree_type[bt][kt];
7832             if (ffesymbol_sfdummyparent (s) != NULL)
7833               {
7834                 if (current_function_decl == ffecom_outer_function_decl_)
7835                   {                     /* Exec transition before sfunc
7836                                            context; get it later. */
7837                     break;
7838                   }
7839                 t = ffecom_get_identifier_ (ffesymbol_text
7840                                             (ffesymbol_sfdummyparent (s)));
7841               }
7842             else
7843               t = ffecom_get_identifier_ (ffesymbol_text (s));
7844
7845             assert (ffecom_transform_only_dummies_);
7846
7847             old_sizes = get_pending_sizes ();
7848             put_pending_sizes (old_sizes);
7849
7850             if (bt == FFEINFO_basictypeCHARACTER)
7851               tlen = ffecom_char_enhance_arg_ (&type, s);
7852             type = ffecom_check_size_overflow_ (s, type, TRUE);
7853
7854             for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
7855               {
7856                 if (type == error_mark_node)
7857                   break;
7858
7859                 dim = ffebld_head (dl);
7860                 assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
7861                 if ((ffebld_left (dim) == NULL) || ffecom_doing_entry_)
7862                   low = ffecom_integer_one_node;
7863                 else
7864                   low = ffecom_expr (ffebld_left (dim));
7865                 assert (ffebld_right (dim) != NULL);
7866                 if ((ffebld_op (ffebld_right (dim)) == FFEBLD_opSTAR)
7867                     || ffecom_doing_entry_)
7868                   {
7869                     /* Used to just do high=low.  But for ffecom_tree_
7870                        canonize_ref_, it probably is important to correctly
7871                        assess the size.  E.g. given COMPLEX C(*),CFUNC and
7872                        C(2)=CFUNC(C), overlap can happen, while it can't
7873                        for, say, C(1)=CFUNC(C(2)).  */
7874                     /* Even more recently used to set to INT_MAX, but that
7875                        broke when some overflow checking went into the back
7876                        end.  Now we just leave the upper bound unspecified.  */
7877                     high = NULL;
7878                   }
7879                 else
7880                   high = ffecom_expr (ffebld_right (dim));
7881
7882                 /* Determine whether array is conditionally adjustable,
7883                    to decide whether back-end magic is needed.
7884
7885                    Normally the front end uses the back-end function
7886                    variable_size to wrap SAVE_EXPR's around expressions
7887                    affecting the size/shape of an array so that the
7888                    size/shape info doesn't change during execution
7889                    of the compiled code even though variables and
7890                    functions referenced in those expressions might.
7891
7892                    variable_size also makes sure those saved expressions
7893                    get evaluated immediately upon entry to the
7894                    compiled procedure -- the front end normally doesn't
7895                    have to worry about that.
7896
7897                    However, there is a problem with this that affects
7898                    g77's implementation of entry points, and that is
7899                    that it is _not_ true that each invocation of the
7900                    compiled procedure is permitted to evaluate
7901                    array size/shape info -- because it is possible
7902                    that, for some invocations, that info is invalid (in
7903                    which case it is "promised" -- i.e. a violation of
7904                    the Fortran standard -- that the compiled code
7905                    won't reference the array or its size/shape
7906                    during that particular invocation).
7907
7908                    To phrase this in C terms, consider this gcc function:
7909
7910                      void foo (int *n, float (*a)[*n])
7911                      {
7912                        // a is "pointer to array ...", fyi.
7913                      }
7914
7915                    Suppose that, for some invocations, it is permitted
7916                    for a caller of foo to do this:
7917
7918                        foo (NULL, NULL);
7919
7920                    Now the _written_ code for foo can take such a call
7921                    into account by either testing explicitly for whether
7922                    (a == NULL) || (n == NULL) -- presumably it is
7923                    not permitted to reference *a in various fashions
7924                    if (n == NULL) I suppose -- or it can avoid it by
7925                    looking at other info (other arguments, static/global
7926                    data, etc.).
7927
7928                    However, this won't work in gcc 2.5.8 because it'll
7929                    automatically emit the code to save the "*n"
7930                    expression, which'll yield a NULL dereference for
7931                    the "foo (NULL, NULL)" call, something the code
7932                    for foo cannot prevent.
7933
7934                    g77 definitely needs to avoid executing such
7935                    code anytime the pointer to the adjustable array
7936                    is NULL, because even if its bounds expressions
7937                    don't have any references to possible "absent"
7938                    variables like "*n" -- say all variable references
7939                    are to COMMON variables, i.e. global (though in C,
7940                    local static could actually make sense) -- the
7941                    expressions could yield other run-time problems
7942                    for allowably "dead" values in those variables.
7943
7944                    For example, let's consider a more complicated
7945                    version of foo:
7946
7947                      extern int i;
7948                      extern int j;
7949
7950                      void foo (float (*a)[i/j])
7951                      {
7952                        ...
7953                      }
7954
7955                    The above is (essentially) quite valid for Fortran
7956                    but, again, for a call like "foo (NULL);", it is
7957                    permitted for i and j to be undefined when the
7958                    call is made.  If j happened to be zero, for
7959                    example, emitting the code to evaluate "i/j"
7960                    could result in a run-time error.
7961
7962                    Offhand, though I don't have my F77 or F90
7963                    standards handy, it might even be valid for a
7964                    bounds expression to contain a function reference,
7965                    in which case I doubt it is permitted for an
7966                    implementation to invoke that function in the
7967                    Fortran case involved here (invocation of an
7968                    alternate ENTRY point that doesn't have the adjustable
7969                    array as one of its arguments).
7970
7971                    So, the code that the compiler would normally emit
7972                    to preevaluate the size/shape info for an
7973                    adjustable array _must not_ be executed at run time
7974                    in certain cases.  Specifically, for Fortran,
7975                    the case is when the pointer to the adjustable
7976                    array == NULL.  (For gnu-ish C, it might be nice
7977                    for the source code itself to specify an expression
7978                    that, if TRUE, inhibits execution of the code.  Or
7979                    reverse the sense for elegance.)
7980
7981                    (Note that g77 could use a different test than NULL,
7982                    actually, since it happens to always pass an
7983                    integer to the called function that specifies which
7984                    entry point is being invoked.  Hmm, this might
7985                    solve the next problem.)
7986
7987                    One way a user could, I suppose, write "foo" so
7988                    it works is to insert COND_EXPR's for the
7989                    size/shape info so the dangerous stuff isn't
7990                    actually done, as in:
7991
7992                      void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
7993                      {
7994                        ...
7995                      }
7996
7997                    The next problem is that the front end needs to
7998                    be able to tell the back end about the array's
7999                    decl _before_ it tells it about the conditional
8000                    expression to inhibit evaluation of size/shape info,
8001                    as shown above.
8002
8003                    To solve this, the front end needs to be able
8004                    to give the back end the expression to inhibit
8005                    generation of the preevaluation code _after_
8006                    it makes the decl for the adjustable array.
8007
8008                    Until then, the above example using the COND_EXPR
8009                    doesn't pass muster with gcc because the "(a == NULL)"
8010                    part has a reference to "a", which is still
8011                    undefined at that point.
8012
8013                    g77 will therefore use a different mechanism in the
8014                    meantime.  */
8015
8016                 if (!adjustable
8017                     && ((TREE_CODE (low) != INTEGER_CST)
8018                         || (high && TREE_CODE (high) != INTEGER_CST)))
8019                   adjustable = TRUE;
8020
8021 #if 0                           /* Old approach -- see below. */
8022                 if (TREE_CODE (low) != INTEGER_CST)
8023                   low = ffecom_3 (COND_EXPR, integer_type_node,
8024                                   ffecom_adjarray_passed_ (s),
8025                                   low,
8026                                   ffecom_integer_zero_node);
8027
8028                 if (high && TREE_CODE (high) != INTEGER_CST)
8029                   high = ffecom_3 (COND_EXPR, integer_type_node,
8030                                    ffecom_adjarray_passed_ (s),
8031                                    high,
8032                                    ffecom_integer_zero_node);
8033 #endif
8034
8035                 /* ~~~gcc/stor-layout.c (layout_type) should do this,
8036                    probably.  Fixes 950302-1.f.  */
8037
8038                 if (TREE_CODE (low) != INTEGER_CST)
8039                   low = variable_size (low);
8040
8041                 /* ~~~Similarly, this fixes dumb0.f.  The C front end
8042                    does this, which is why dumb0.c would work.  */
8043
8044                 if (high && TREE_CODE (high) != INTEGER_CST)
8045                   high = variable_size (high);
8046
8047                 type
8048                   = build_array_type
8049                     (type,
8050                      build_range_type (ffecom_integer_type_node,
8051                                        low, high));
8052                 type = ffecom_check_size_overflow_ (s, type, TRUE);
8053               }
8054
8055             if (type == error_mark_node)
8056               {
8057                 t = error_mark_node;
8058                 break;
8059               }
8060
8061             if ((ffesymbol_sfdummyparent (s) == NULL)
8062                  || (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
8063               {
8064                 type = build_pointer_type (type);
8065                 addr = TRUE;
8066               }
8067
8068             t = build_decl (PARM_DECL, t, type);
8069 #if BUILT_FOR_270
8070             DECL_ARTIFICIAL (t) = 1;
8071 #endif
8072
8073             /* If this arg is present in every entry point's list of
8074                dummy args, then we're done.  */
8075
8076             if (ffesymbol_numentries (s)
8077                 == (ffecom_num_entrypoints_ + 1))
8078               break;
8079
8080 #if 1
8081
8082             /* If variable_size in stor-layout has been called during
8083                the above, then get_pending_sizes should have the
8084                yet-to-be-evaluated saved expressions pending.
8085                Make the whole lot of them get emitted, conditionally
8086                on whether the array decl ("t" above) is not NULL.  */
8087
8088             {
8089               tree sizes = get_pending_sizes ();
8090               tree tem;
8091
8092               for (tem = sizes;
8093                    tem != old_sizes;
8094                    tem = TREE_CHAIN (tem))
8095                 {
8096                   tree temv = TREE_VALUE (tem);
8097
8098                   if (sizes == tem)
8099                     sizes = temv;
8100                   else
8101                     sizes
8102                       = ffecom_2 (COMPOUND_EXPR,
8103                                   TREE_TYPE (sizes),
8104                                   temv,
8105                                   sizes);
8106                 }
8107
8108               if (sizes != tem)
8109                 {
8110                   sizes
8111                     = ffecom_3 (COND_EXPR,
8112                                 TREE_TYPE (sizes),
8113                                 ffecom_2 (NE_EXPR,
8114                                           integer_type_node,
8115                                           t,
8116                                           null_pointer_node),
8117                                 sizes,
8118                                 convert (TREE_TYPE (sizes),
8119                                          integer_zero_node));
8120                   sizes = ffecom_save_tree (sizes);
8121
8122                   sizes
8123                     = tree_cons (NULL_TREE, sizes, tem);
8124                 }
8125
8126               if (sizes)
8127                 put_pending_sizes (sizes);
8128             }
8129
8130 #else
8131 #if 0
8132             if (adjustable
8133                 && (ffesymbol_numentries (s)
8134                     != ffecom_num_entrypoints_ + 1))
8135               DECL_SOMETHING (t)
8136                 = ffecom_2 (NE_EXPR, integer_type_node,
8137                             t,
8138                             null_pointer_node);
8139 #else
8140 #if 0
8141             if (adjustable
8142                 && (ffesymbol_numentries (s)
8143                     != ffecom_num_entrypoints_ + 1))
8144               {
8145                 ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED);
8146                 ffebad_here (0, ffesymbol_where_line (s),
8147                              ffesymbol_where_column (s));
8148                 ffebad_string (ffesymbol_text (s));
8149                 ffebad_finish ();
8150               }
8151 #endif
8152 #endif
8153 #endif
8154           }
8155           break;
8156
8157         case FFEINFO_whereCOMMON:
8158           {
8159             ffesymbol cs;
8160             ffeglobal cg;
8161             tree ct;
8162             ffestorag st = ffesymbol_storage (s);
8163             tree type;
8164             int yes;
8165
8166             cs = ffesymbol_common (s);  /* The COMMON area itself.  */
8167             if (st != NULL)     /* Else not laid out. */
8168               {
8169                 ffecom_transform_common_ (cs);
8170                 st = ffesymbol_storage (s);
8171               }
8172
8173             yes = suspend_momentary ();
8174
8175             type = ffecom_type_localvar_ (s, bt, kt);
8176
8177             cg = ffesymbol_global (cs); /* The global COMMON info.  */
8178             if ((cg == NULL)
8179                 || (ffeglobal_type (cg) != FFEGLOBAL_typeCOMMON))
8180               ct = NULL_TREE;
8181             else
8182               ct = ffeglobal_hook (cg); /* The common area's tree.  */
8183
8184             if ((ct == NULL_TREE)
8185                 || (st == NULL)
8186                 || (type == error_mark_node))
8187               t = error_mark_node;
8188             else
8189               {
8190                 ffetargetOffset offset;
8191                 ffestorag cst;
8192
8193                 cst = ffestorag_parent (st);
8194                 assert (cst == ffesymbol_storage (cs));
8195
8196                 offset = ffestorag_modulo (cst)
8197                   + ffestorag_offset (st)
8198                   - ffestorag_offset (cst);
8199
8200                 ffecom_debug_kludge_ (ct, "COMMON", s, type, offset);
8201
8202                 /* (t_type *) (((char *) &ct) + offset) */
8203
8204                 t = convert (string_type_node,  /* (char *) */
8205                              ffecom_1 (ADDR_EXPR,
8206                                        build_pointer_type (TREE_TYPE (ct)),
8207                                        ct));
8208                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
8209                               t,
8210                               build_int_2 (offset, 0));
8211                 t = convert (build_pointer_type (type),
8212                              t);
8213                 TREE_CONSTANT (t) = 1;
8214
8215                 addr = TRUE;
8216               }
8217
8218             resume_momentary (yes);
8219           }
8220           break;
8221
8222         case FFEINFO_whereIMMEDIATE:
8223         case FFEINFO_whereGLOBAL:
8224         case FFEINFO_whereFLEETING:
8225         case FFEINFO_whereFLEETING_CADDR:
8226         case FFEINFO_whereFLEETING_IADDR:
8227         case FFEINFO_whereINTRINSIC:
8228         case FFEINFO_whereCONSTANT_SUBOBJECT:
8229         default:
8230           assert ("ENTITY where unheard of" == NULL);
8231           /* Fall through. */
8232         case FFEINFO_whereANY:
8233           t = error_mark_node;
8234           break;
8235         }
8236       break;
8237
8238     case FFEINFO_kindFUNCTION:
8239       switch (ffeinfo_where (ffesymbol_info (s)))
8240         {
8241         case FFEINFO_whereLOCAL:        /* Me. */
8242           assert (!ffecom_transform_only_dummies_);
8243           t = current_function_decl;
8244           break;
8245
8246         case FFEINFO_whereGLOBAL:
8247           assert (!ffecom_transform_only_dummies_);
8248
8249           if (((g = ffesymbol_global (s)) != NULL)
8250               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8251                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8252               && (ffeglobal_hook (g) != NULL_TREE)
8253               && ffe_is_globals ())
8254             {
8255               t = ffeglobal_hook (g);
8256               break;
8257             }
8258
8259           if (ffesymbol_is_f2c (s)
8260               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8261             t = ffecom_tree_fun_type[bt][kt];
8262           else
8263             t = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
8264
8265           t = build_decl (FUNCTION_DECL,
8266                           ffecom_get_external_identifier_ (s),
8267                           t);
8268           DECL_EXTERNAL (t) = 1;
8269           TREE_PUBLIC (t) = 1;
8270
8271           t = start_decl (t, FALSE);
8272           finish_decl (t, NULL_TREE, FALSE);
8273
8274           if ((g != NULL)
8275               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8276                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8277             ffeglobal_set_hook (g, t);
8278
8279           ffecom_save_tree_forever (t);
8280
8281           break;
8282
8283         case FFEINFO_whereDUMMY:
8284           assert (ffecom_transform_only_dummies_);
8285
8286           if (ffesymbol_is_f2c (s)
8287               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8288             t = ffecom_tree_ptr_to_fun_type[bt][kt];
8289           else
8290             t = build_pointer_type
8291               (build_function_type (ffecom_tree_type[bt][kt], NULL_TREE));
8292
8293           t = build_decl (PARM_DECL,
8294                           ffecom_get_identifier_ (ffesymbol_text (s)),
8295                           t);
8296 #if BUILT_FOR_270
8297           DECL_ARTIFICIAL (t) = 1;
8298 #endif
8299           addr = TRUE;
8300           break;
8301
8302         case FFEINFO_whereCONSTANT:     /* Statement function. */
8303           assert (!ffecom_transform_only_dummies_);
8304           t = ffecom_gen_sfuncdef_ (s, bt, kt);
8305           break;
8306
8307         case FFEINFO_whereINTRINSIC:
8308           assert (!ffecom_transform_only_dummies_);
8309           break;                /* Let actual references generate their
8310                                    decls. */
8311
8312         default:
8313           assert ("FUNCTION where unheard of" == NULL);
8314           /* Fall through. */
8315         case FFEINFO_whereANY:
8316           t = error_mark_node;
8317           break;
8318         }
8319       break;
8320
8321     case FFEINFO_kindSUBROUTINE:
8322       switch (ffeinfo_where (ffesymbol_info (s)))
8323         {
8324         case FFEINFO_whereLOCAL:        /* Me. */
8325           assert (!ffecom_transform_only_dummies_);
8326           t = current_function_decl;
8327           break;
8328
8329         case FFEINFO_whereGLOBAL:
8330           assert (!ffecom_transform_only_dummies_);
8331
8332           if (((g = ffesymbol_global (s)) != NULL)
8333               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8334                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8335               && (ffeglobal_hook (g) != NULL_TREE)
8336               && ffe_is_globals ())
8337             {
8338               t = ffeglobal_hook (g);
8339               break;
8340             }
8341
8342           t = build_decl (FUNCTION_DECL,
8343                           ffecom_get_external_identifier_ (s),
8344                           ffecom_tree_subr_type);
8345           DECL_EXTERNAL (t) = 1;
8346           TREE_PUBLIC (t) = 1;
8347
8348           t = start_decl (t, FALSE);
8349           finish_decl (t, NULL_TREE, FALSE);
8350
8351           if ((g != NULL)
8352               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8353                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8354             ffeglobal_set_hook (g, t);
8355
8356           ffecom_save_tree_forever (t);
8357
8358           break;
8359
8360         case FFEINFO_whereDUMMY:
8361           assert (ffecom_transform_only_dummies_);
8362
8363           t = build_decl (PARM_DECL,
8364                           ffecom_get_identifier_ (ffesymbol_text (s)),
8365                           ffecom_tree_ptr_to_subr_type);
8366 #if BUILT_FOR_270
8367           DECL_ARTIFICIAL (t) = 1;
8368 #endif
8369           addr = TRUE;
8370           break;
8371
8372         case FFEINFO_whereINTRINSIC:
8373           assert (!ffecom_transform_only_dummies_);
8374           break;                /* Let actual references generate their
8375                                    decls. */
8376
8377         default:
8378           assert ("SUBROUTINE where unheard of" == NULL);
8379           /* Fall through. */
8380         case FFEINFO_whereANY:
8381           t = error_mark_node;
8382           break;
8383         }
8384       break;
8385
8386     case FFEINFO_kindPROGRAM:
8387       switch (ffeinfo_where (ffesymbol_info (s)))
8388         {
8389         case FFEINFO_whereLOCAL:        /* Me. */
8390           assert (!ffecom_transform_only_dummies_);
8391           t = current_function_decl;
8392           break;
8393
8394         case FFEINFO_whereCOMMON:
8395         case FFEINFO_whereDUMMY:
8396         case FFEINFO_whereGLOBAL:
8397         case FFEINFO_whereRESULT:
8398         case FFEINFO_whereFLEETING:
8399         case FFEINFO_whereFLEETING_CADDR:
8400         case FFEINFO_whereFLEETING_IADDR:
8401         case FFEINFO_whereIMMEDIATE:
8402         case FFEINFO_whereINTRINSIC:
8403         case FFEINFO_whereCONSTANT:
8404         case FFEINFO_whereCONSTANT_SUBOBJECT:
8405         default:
8406           assert ("PROGRAM where unheard of" == NULL);
8407           /* Fall through. */
8408         case FFEINFO_whereANY:
8409           t = error_mark_node;
8410           break;
8411         }
8412       break;
8413
8414     case FFEINFO_kindBLOCKDATA:
8415       switch (ffeinfo_where (ffesymbol_info (s)))
8416         {
8417         case FFEINFO_whereLOCAL:        /* Me. */
8418           assert (!ffecom_transform_only_dummies_);
8419           t = current_function_decl;
8420           break;
8421
8422         case FFEINFO_whereGLOBAL:
8423           assert (!ffecom_transform_only_dummies_);
8424
8425           t = build_decl (FUNCTION_DECL,
8426                           ffecom_get_external_identifier_ (s),
8427                           ffecom_tree_blockdata_type);
8428           DECL_EXTERNAL (t) = 1;
8429           TREE_PUBLIC (t) = 1;
8430
8431           t = start_decl (t, FALSE);
8432           finish_decl (t, NULL_TREE, FALSE);
8433
8434           ffecom_save_tree_forever (t);
8435
8436           break;
8437
8438         case FFEINFO_whereCOMMON:
8439         case FFEINFO_whereDUMMY:
8440         case FFEINFO_whereRESULT:
8441         case FFEINFO_whereFLEETING:
8442         case FFEINFO_whereFLEETING_CADDR:
8443         case FFEINFO_whereFLEETING_IADDR:
8444         case FFEINFO_whereIMMEDIATE:
8445         case FFEINFO_whereINTRINSIC:
8446         case FFEINFO_whereCONSTANT:
8447         case FFEINFO_whereCONSTANT_SUBOBJECT:
8448         default:
8449           assert ("BLOCKDATA where unheard of" == NULL);
8450           /* Fall through. */
8451         case FFEINFO_whereANY:
8452           t = error_mark_node;
8453           break;
8454         }
8455       break;
8456
8457     case FFEINFO_kindCOMMON:
8458       switch (ffeinfo_where (ffesymbol_info (s)))
8459         {
8460         case FFEINFO_whereLOCAL:
8461           assert (!ffecom_transform_only_dummies_);
8462           ffecom_transform_common_ (s);
8463           break;
8464
8465         case FFEINFO_whereNONE:
8466         case FFEINFO_whereCOMMON:
8467         case FFEINFO_whereDUMMY:
8468         case FFEINFO_whereGLOBAL:
8469         case FFEINFO_whereRESULT:
8470         case FFEINFO_whereFLEETING:
8471         case FFEINFO_whereFLEETING_CADDR:
8472         case FFEINFO_whereFLEETING_IADDR:
8473         case FFEINFO_whereIMMEDIATE:
8474         case FFEINFO_whereINTRINSIC:
8475         case FFEINFO_whereCONSTANT:
8476         case FFEINFO_whereCONSTANT_SUBOBJECT:
8477         default:
8478           assert ("COMMON where unheard of" == NULL);
8479           /* Fall through. */
8480         case FFEINFO_whereANY:
8481           t = error_mark_node;
8482           break;
8483         }
8484       break;
8485
8486     case FFEINFO_kindCONSTRUCT:
8487       switch (ffeinfo_where (ffesymbol_info (s)))
8488         {
8489         case FFEINFO_whereLOCAL:
8490           assert (!ffecom_transform_only_dummies_);
8491           break;
8492
8493         case FFEINFO_whereNONE:
8494         case FFEINFO_whereCOMMON:
8495         case FFEINFO_whereDUMMY:
8496         case FFEINFO_whereGLOBAL:
8497         case FFEINFO_whereRESULT:
8498         case FFEINFO_whereFLEETING:
8499         case FFEINFO_whereFLEETING_CADDR:
8500         case FFEINFO_whereFLEETING_IADDR:
8501         case FFEINFO_whereIMMEDIATE:
8502         case FFEINFO_whereINTRINSIC:
8503         case FFEINFO_whereCONSTANT:
8504         case FFEINFO_whereCONSTANT_SUBOBJECT:
8505         default:
8506           assert ("CONSTRUCT where unheard of" == NULL);
8507           /* Fall through. */
8508         case FFEINFO_whereANY:
8509           t = error_mark_node;
8510           break;
8511         }
8512       break;
8513
8514     case FFEINFO_kindNAMELIST:
8515       switch (ffeinfo_where (ffesymbol_info (s)))
8516         {
8517         case FFEINFO_whereLOCAL:
8518           assert (!ffecom_transform_only_dummies_);
8519           t = ffecom_transform_namelist_ (s);
8520           break;
8521
8522         case FFEINFO_whereNONE:
8523         case FFEINFO_whereCOMMON:
8524         case FFEINFO_whereDUMMY:
8525         case FFEINFO_whereGLOBAL:
8526         case FFEINFO_whereRESULT:
8527         case FFEINFO_whereFLEETING:
8528         case FFEINFO_whereFLEETING_CADDR:
8529         case FFEINFO_whereFLEETING_IADDR:
8530         case FFEINFO_whereIMMEDIATE:
8531         case FFEINFO_whereINTRINSIC:
8532         case FFEINFO_whereCONSTANT:
8533         case FFEINFO_whereCONSTANT_SUBOBJECT:
8534         default:
8535           assert ("NAMELIST where unheard of" == NULL);
8536           /* Fall through. */
8537         case FFEINFO_whereANY:
8538           t = error_mark_node;
8539           break;
8540         }
8541       break;
8542
8543     default:
8544       assert ("kind unheard of" == NULL);
8545       /* Fall through. */
8546     case FFEINFO_kindANY:
8547       t = error_mark_node;
8548       break;
8549     }
8550
8551   ffesymbol_hook (s).decl_tree = t;
8552   ffesymbol_hook (s).length_tree = tlen;
8553   ffesymbol_hook (s).addr = addr;
8554
8555   lineno = old_lineno;
8556   input_filename = old_input_filename;
8557
8558   return s;
8559 }
8560
8561 #endif
8562 /* Transform into ASSIGNable symbol.
8563
8564    Symbol has already been transformed, but for whatever reason, the
8565    resulting decl_tree has been deemed not usable for an ASSIGN target.
8566    (E.g. it isn't wide enough to hold a pointer.)  So, here we invent
8567    another local symbol of type void * and stuff that in the assign_tree
8568    argument.  The F77/F90 standards allow this implementation.  */
8569
8570 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8571 static ffesymbol
8572 ffecom_sym_transform_assign_ (ffesymbol s)
8573 {
8574   tree t;                       /* Transformed thingy. */
8575   int yes;
8576   int old_lineno = lineno;
8577   const char *old_input_filename = input_filename;
8578
8579   if (ffesymbol_sfdummyparent (s) == NULL)
8580     {
8581       input_filename = ffesymbol_where_filename (s);
8582       lineno = ffesymbol_where_filelinenum (s);
8583     }
8584   else
8585     {
8586       ffesymbol sf = ffesymbol_sfdummyparent (s);
8587
8588       input_filename = ffesymbol_where_filename (sf);
8589       lineno = ffesymbol_where_filelinenum (sf);
8590     }
8591
8592   assert (!ffecom_transform_only_dummies_);
8593
8594   yes = suspend_momentary ();
8595
8596   t = build_decl (VAR_DECL,
8597                   ffecom_get_invented_identifier ("__g77_ASSIGN_%s",
8598                                                    ffesymbol_text (s)),
8599                   TREE_TYPE (null_pointer_node));
8600
8601   switch (ffesymbol_where (s))
8602     {
8603     case FFEINFO_whereLOCAL:
8604       /* Unlike for regular vars, SAVE status is easy to determine for
8605          ASSIGNed vars, since there's no initialization, there's no
8606          effective storage association (so "SAVE J" does not apply to
8607          K even given "EQUIVALENCE (J,K)"), there's no size issue
8608          to worry about, etc.  */
8609       if ((ffesymbol_is_save (s) || ffe_is_saveall ())
8610           && (ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8611           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA))
8612         TREE_STATIC (t) = 1;    /* SAVEd in proc, make static. */
8613       else
8614         TREE_STATIC (t) = 0;    /* No need to make static. */
8615       break;
8616
8617     case FFEINFO_whereCOMMON:
8618       TREE_STATIC (t) = 1;      /* Assume COMMONs always SAVEd. */
8619       break;
8620
8621     case FFEINFO_whereDUMMY:
8622       /* Note that twinning a DUMMY means the caller won't see
8623          the ASSIGNed value.  But both F77 and F90 allow implementations
8624          to do this, i.e. disallow Fortran code that would try and
8625          take advantage of actually putting a label into a variable
8626          via a dummy argument (or any other storage association, for
8627          that matter).  */
8628       TREE_STATIC (t) = 0;
8629       break;
8630
8631     default:
8632       TREE_STATIC (t) = 0;
8633       break;
8634     }
8635
8636   t = start_decl (t, FALSE);
8637   finish_decl (t, NULL_TREE, FALSE);
8638
8639   resume_momentary (yes);
8640
8641   ffesymbol_hook (s).assign_tree = t;
8642
8643   lineno = old_lineno;
8644   input_filename = old_input_filename;
8645
8646   return s;
8647 }
8648
8649 #endif
8650 /* Implement COMMON area in back end.
8651
8652    Because COMMON-based variables can be referenced in the dimension
8653    expressions of dummy (adjustable) arrays, and because dummies
8654    (in the gcc back end) need to be put in the outer binding level
8655    of a function (which has two binding levels, the outer holding
8656    the dummies and the inner holding the other vars), special care
8657    must be taken to handle COMMON areas.
8658
8659    The current strategy is basically to always tell the back end about
8660    the COMMON area as a top-level external reference to just a block
8661    of storage of the master type of that area (e.g. integer, real,
8662    character, whatever -- not a structure).  As a distinct action,
8663    if initial values are provided, tell the back end about the area
8664    as a top-level non-external (initialized) area and remember not to
8665    allow further initialization or expansion of the area.  Meanwhile,
8666    if no initialization happens at all, tell the back end about
8667    the largest size we've seen declared so the space does get reserved.
8668    (This function doesn't handle all that stuff, but it does some
8669    of the important things.)
8670
8671    Meanwhile, for COMMON variables themselves, just keep creating
8672    references like *((float *) (&common_area + offset)) each time
8673    we reference the variable.  In other words, don't make a VAR_DECL
8674    or any kind of component reference (like we used to do before 0.4),
8675    though we might do that as well just for debugging purposes (and
8676    stuff the rtl with the appropriate offset expression).  */
8677
8678 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8679 static void
8680 ffecom_transform_common_ (ffesymbol s)
8681 {
8682   ffestorag st = ffesymbol_storage (s);
8683   ffeglobal g = ffesymbol_global (s);
8684   tree cbt;
8685   tree cbtype;
8686   tree init;
8687   tree high;
8688   bool is_init = ffestorag_is_init (st);
8689
8690   assert (st != NULL);
8691
8692   if ((g == NULL)
8693       || (ffeglobal_type (g) != FFEGLOBAL_typeCOMMON))
8694     return;
8695
8696   /* First update the size of the area in global terms.  */
8697
8698   ffeglobal_size_common (s, ffestorag_size (st));
8699
8700   if (!ffeglobal_common_init (g))
8701     is_init = FALSE;    /* No explicit init, don't let erroneous joins init. */
8702
8703   cbt = ffeglobal_hook (g);
8704
8705   /* If we already have declared this common block for a previous program
8706      unit, and either we already initialized it or we don't have new
8707      initialization for it, just return what we have without changing it.  */
8708
8709   if ((cbt != NULL_TREE)
8710       && (!is_init
8711           || !DECL_EXTERNAL (cbt)))
8712     {
8713       if (st->hook == NULL) ffestorag_set_hook (st, cbt);
8714       return;
8715     }
8716
8717   /* Process inits.  */
8718
8719   if (is_init)
8720     {
8721       if (ffestorag_init (st) != NULL)
8722         {
8723           ffebld sexp;
8724
8725           /* Set the padding for the expression, so ffecom_expr
8726              knows to insert that many zeros.  */
8727           switch (ffebld_op (sexp = ffestorag_init (st)))
8728             {
8729             case FFEBLD_opCONTER:
8730               ffebld_conter_set_pad (sexp, ffestorag_modulo (st));
8731               break;
8732
8733             case FFEBLD_opARRTER:
8734               ffebld_arrter_set_pad (sexp, ffestorag_modulo (st));
8735               break;
8736
8737             case FFEBLD_opACCTER:
8738               ffebld_accter_set_pad (sexp, ffestorag_modulo (st));
8739               break;
8740
8741             default:
8742               assert ("bad op for cmn init (pad)" == NULL);
8743               break;
8744             }
8745
8746           init = ffecom_expr (sexp);
8747           if (init == error_mark_node)
8748             {                   /* Hopefully the back end complained! */
8749               init = NULL_TREE;
8750               if (cbt != NULL_TREE)
8751                 return;
8752             }
8753         }
8754       else
8755         init = error_mark_node;
8756     }
8757   else
8758     init = NULL_TREE;
8759
8760   /* cbtype must be permanently allocated!  */
8761
8762   /* Allocate the MAX of the areas so far, seen filewide.  */
8763   high = build_int_2 ((ffeglobal_common_size (g)
8764                        + ffeglobal_common_pad (g)) - 1, 0);
8765   TREE_TYPE (high) = ffecom_integer_type_node;
8766
8767   if (init)
8768     cbtype = build_array_type (char_type_node,
8769                                build_range_type (integer_type_node,
8770                                                  integer_zero_node,
8771                                                  high));
8772   else
8773     cbtype = build_array_type (char_type_node, NULL_TREE);
8774
8775   if (cbt == NULL_TREE)
8776     {
8777       cbt
8778         = build_decl (VAR_DECL,
8779                       ffecom_get_external_identifier_ (s),
8780                       cbtype);
8781       TREE_STATIC (cbt) = 1;
8782       TREE_PUBLIC (cbt) = 1;
8783     }
8784   else
8785     {
8786       assert (is_init);
8787       TREE_TYPE (cbt) = cbtype;
8788     }
8789   DECL_EXTERNAL (cbt) = init ? 0 : 1;
8790   DECL_INITIAL (cbt) = init ? error_mark_node : NULL_TREE;
8791
8792   cbt = start_decl (cbt, TRUE);
8793   if (ffeglobal_hook (g) != NULL)
8794     assert (cbt == ffeglobal_hook (g));
8795
8796   assert (!init || !DECL_EXTERNAL (cbt));
8797
8798   /* Make sure that any type can live in COMMON and be referenced
8799      without getting a bus error.  We could pick the most restrictive
8800      alignment of all entities actually placed in the COMMON, but
8801      this seems easy enough.  */
8802
8803   DECL_ALIGN (cbt) = BIGGEST_ALIGNMENT;
8804
8805   if (is_init && (ffestorag_init (st) == NULL))
8806     init = ffecom_init_zero_ (cbt);
8807
8808   finish_decl (cbt, init, TRUE);
8809
8810   if (is_init)
8811     ffestorag_set_init (st, ffebld_new_any ());
8812
8813   if (init)
8814     {
8815       assert (DECL_SIZE_UNIT (cbt) != NULL_TREE);
8816       assert (TREE_CODE (DECL_SIZE_UNIT (cbt)) == INTEGER_CST);
8817       assert (0 == compare_tree_int (DECL_SIZE_UNIT (cbt),
8818                                      (ffeglobal_common_size (g)
8819                                       + ffeglobal_common_pad (g))));
8820     }
8821
8822   ffeglobal_set_hook (g, cbt);
8823
8824   ffestorag_set_hook (st, cbt);
8825
8826   ffecom_save_tree_forever (cbt);
8827 }
8828
8829 #endif
8830 /* Make master area for local EQUIVALENCE.  */
8831
8832 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8833 static void
8834 ffecom_transform_equiv_ (ffestorag eqst)
8835 {
8836   tree eqt;
8837   tree eqtype;
8838   tree init;
8839   tree high;
8840   bool is_init = ffestorag_is_init (eqst);
8841   int yes;
8842
8843   assert (eqst != NULL);
8844
8845   eqt = ffestorag_hook (eqst);
8846
8847   if (eqt != NULL_TREE)
8848     return;
8849
8850   /* Process inits.  */
8851
8852   if (is_init)
8853     {
8854       if (ffestorag_init (eqst) != NULL)
8855         {
8856           ffebld sexp;
8857
8858           /* Set the padding for the expression, so ffecom_expr
8859              knows to insert that many zeros.  */
8860           switch (ffebld_op (sexp = ffestorag_init (eqst)))
8861             {
8862             case FFEBLD_opCONTER:
8863               ffebld_conter_set_pad (sexp, ffestorag_modulo (eqst));
8864               break;
8865
8866             case FFEBLD_opARRTER:
8867               ffebld_arrter_set_pad (sexp, ffestorag_modulo (eqst));
8868               break;
8869
8870             case FFEBLD_opACCTER:
8871               ffebld_accter_set_pad (sexp, ffestorag_modulo (eqst));
8872               break;
8873
8874             default:
8875               assert ("bad op for eqv init (pad)" == NULL);
8876               break;
8877             }
8878
8879           init = ffecom_expr (sexp);
8880           if (init == error_mark_node)
8881             init = NULL_TREE;   /* Hopefully the back end complained! */
8882         }
8883       else
8884         init = error_mark_node;
8885     }
8886   else if (ffe_is_init_local_zero ())
8887     init = error_mark_node;
8888   else
8889     init = NULL_TREE;
8890
8891   ffecom_member_namelisted_ = FALSE;
8892   ffestorag_drive (ffestorag_list_equivs (eqst),
8893                    &ffecom_member_phase1_,
8894                    eqst);
8895
8896   yes = suspend_momentary ();
8897
8898   high = build_int_2 ((ffestorag_size (eqst)
8899                        + ffestorag_modulo (eqst)) - 1, 0);
8900   TREE_TYPE (high) = ffecom_integer_type_node;
8901
8902   eqtype = build_array_type (char_type_node,
8903                              build_range_type (ffecom_integer_type_node,
8904                                                ffecom_integer_zero_node,
8905                                                high));
8906
8907   eqt = build_decl (VAR_DECL,
8908                     ffecom_get_invented_identifier ("__g77_equiv_%s",
8909                                                     ffesymbol_text
8910                                                     (ffestorag_symbol (eqst))),
8911                     eqtype);
8912   DECL_EXTERNAL (eqt) = 0;
8913   if (is_init
8914       || ffecom_member_namelisted_
8915 #ifdef FFECOM_sizeMAXSTACKITEM
8916       || (ffestorag_size (eqst) > FFECOM_sizeMAXSTACKITEM)
8917 #endif
8918       || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8919           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
8920           && (ffestorag_is_save (eqst) || ffe_is_saveall ())))
8921     TREE_STATIC (eqt) = 1;
8922   else
8923     TREE_STATIC (eqt) = 0;
8924   TREE_PUBLIC (eqt) = 0;
8925   DECL_CONTEXT (eqt) = current_function_decl;
8926   if (init)
8927     DECL_INITIAL (eqt) = error_mark_node;
8928   else
8929     DECL_INITIAL (eqt) = NULL_TREE;
8930
8931   eqt = start_decl (eqt, FALSE);
8932
8933   /* Make sure that any type can live in EQUIVALENCE and be referenced
8934      without getting a bus error.  We could pick the most restrictive
8935      alignment of all entities actually placed in the EQUIVALENCE, but
8936      this seems easy enough.  */
8937
8938   DECL_ALIGN (eqt) = BIGGEST_ALIGNMENT;
8939
8940   if ((!is_init && ffe_is_init_local_zero ())
8941       || (is_init && (ffestorag_init (eqst) == NULL)))
8942     init = ffecom_init_zero_ (eqt);
8943
8944   finish_decl (eqt, init, FALSE);
8945
8946   if (is_init)
8947     ffestorag_set_init (eqst, ffebld_new_any ());
8948
8949   {
8950     assert (TREE_CODE (DECL_SIZE_UNIT (eqt)) == INTEGER_CST);
8951     assert (0 == compare_tree_int (DECL_SIZE_UNIT (eqt),
8952                                    (ffestorag_size (eqst)
8953                                     + ffestorag_modulo (eqst))));
8954   }
8955
8956   ffestorag_set_hook (eqst, eqt);
8957
8958 #ifdef SOMEONE_GETS_DEBUG_SUPPORT_WORKING
8959   ffestorag_drive (ffestorag_list_equivs (eqst),
8960                    &ffecom_member_phase2_,
8961                    eqst);
8962 #endif
8963
8964   resume_momentary (yes);
8965 }
8966
8967 #endif
8968 /* Implement NAMELIST in back end.  See f2c/format.c for more info.  */
8969
8970 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8971 static tree
8972 ffecom_transform_namelist_ (ffesymbol s)
8973 {
8974   tree nmlt;
8975   tree nmltype = ffecom_type_namelist_ ();
8976   tree nmlinits;
8977   tree nameinit;
8978   tree varsinit;
8979   tree nvarsinit;
8980   tree field;
8981   tree high;
8982   int yes;
8983   int i;
8984   static int mynumber = 0;
8985
8986   yes = suspend_momentary ();
8987
8988   nmlt = build_decl (VAR_DECL,
8989                      ffecom_get_invented_identifier ("__g77_namelist_%d",
8990                                                      mynumber++),
8991                      nmltype);
8992   TREE_STATIC (nmlt) = 1;
8993   DECL_INITIAL (nmlt) = error_mark_node;
8994
8995   nmlt = start_decl (nmlt, FALSE);
8996
8997   /* Process inits.  */
8998
8999   i = strlen (ffesymbol_text (s));
9000
9001   high = build_int_2 (i, 0);
9002   TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
9003
9004   nameinit = ffecom_build_f2c_string_ (i + 1,
9005                                        ffesymbol_text (s));
9006   TREE_TYPE (nameinit)
9007     = build_type_variant
9008     (build_array_type
9009      (char_type_node,
9010       build_range_type (ffecom_f2c_ftnlen_type_node,
9011                         ffecom_f2c_ftnlen_one_node,
9012                         high)),
9013      1, 0);
9014   TREE_CONSTANT (nameinit) = 1;
9015   TREE_STATIC (nameinit) = 1;
9016   nameinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (nameinit)),
9017                        nameinit);
9018
9019   varsinit = ffecom_vardesc_array_ (s);
9020   varsinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (varsinit)),
9021                        varsinit);
9022   TREE_CONSTANT (varsinit) = 1;
9023   TREE_STATIC (varsinit) = 1;
9024
9025   {
9026     ffebld b;
9027
9028     for (i = 0, b = ffesymbol_namelist (s); b != NULL; b = ffebld_trail (b))
9029       ++i;
9030   }
9031   nvarsinit = build_int_2 (i, 0);
9032   TREE_TYPE (nvarsinit) = integer_type_node;
9033   TREE_CONSTANT (nvarsinit) = 1;
9034   TREE_STATIC (nvarsinit) = 1;
9035
9036   nmlinits = build_tree_list ((field = TYPE_FIELDS (nmltype)), nameinit);
9037   TREE_CHAIN (nmlinits) = build_tree_list ((field = TREE_CHAIN (field)),
9038                                            varsinit);
9039   TREE_CHAIN (TREE_CHAIN (nmlinits))
9040     = build_tree_list ((field = TREE_CHAIN (field)), nvarsinit);
9041
9042   nmlinits = build (CONSTRUCTOR, nmltype, NULL_TREE, nmlinits);
9043   TREE_CONSTANT (nmlinits) = 1;
9044   TREE_STATIC (nmlinits) = 1;
9045
9046   finish_decl (nmlt, nmlinits, FALSE);
9047
9048   nmlt = ffecom_1 (ADDR_EXPR, build_pointer_type (nmltype), nmlt);
9049
9050   resume_momentary (yes);
9051
9052   return nmlt;
9053 }
9054
9055 #endif
9056
9057 /* A subroutine of ffecom_tree_canonize_ref_.  The incoming tree is
9058    analyzed on the assumption it is calculating a pointer to be
9059    indirected through.  It must return the proper decl and offset,
9060    taking into account different units of measurements for offsets.  */
9061
9062 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9063 static void
9064 ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
9065                            tree t)
9066 {
9067   switch (TREE_CODE (t))
9068     {
9069     case NOP_EXPR:
9070     case CONVERT_EXPR:
9071     case NON_LVALUE_EXPR:
9072       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
9073       break;
9074
9075     case PLUS_EXPR:
9076       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
9077       if ((*decl == NULL_TREE)
9078           || (*decl == error_mark_node))
9079         break;
9080
9081       if (TREE_CODE (TREE_OPERAND (t, 1)) == INTEGER_CST)
9082         {
9083           /* An offset into COMMON.  */
9084           *offset = fold (build (PLUS_EXPR, TREE_TYPE (*offset),
9085                                  *offset, TREE_OPERAND (t, 1)));
9086           /* Convert offset (presumably in bytes) into canonical units
9087              (presumably bits).  */
9088           *offset = size_binop (MULT_EXPR,
9089                                 convert (bitsizetype, *offset),
9090                                 TYPE_SIZE (TREE_TYPE (TREE_TYPE (t))));
9091           break;
9092         }
9093       /* Not a COMMON reference, so an unrecognized pattern.  */
9094       *decl = error_mark_node;
9095       break;
9096
9097     case PARM_DECL:
9098       *decl = t;
9099       *offset = bitsize_zero_node;
9100       break;
9101
9102     case ADDR_EXPR:
9103       if (TREE_CODE (TREE_OPERAND (t, 0)) == VAR_DECL)
9104         {
9105           /* A reference to COMMON.  */
9106           *decl = TREE_OPERAND (t, 0);
9107           *offset = bitsize_zero_node;
9108           break;
9109         }
9110       /* Fall through.  */
9111     default:
9112       /* Not a COMMON reference, so an unrecognized pattern.  */
9113       *decl = error_mark_node;
9114       break;
9115     }
9116 }
9117 #endif
9118
9119 /* Given a tree that is possibly intended for use as an lvalue, return
9120    information representing a canonical view of that tree as a decl, an
9121    offset into that decl, and a size for the lvalue.
9122
9123    If there's no applicable decl, NULL_TREE is returned for the decl,
9124    and the other fields are left undefined.
9125
9126    If the tree doesn't fit the recognizable forms, an ERROR_MARK node
9127    is returned for the decl, and the other fields are left undefined.
9128
9129    Otherwise, the decl returned currently is either a VAR_DECL or a
9130    PARM_DECL.
9131
9132    The offset returned is always valid, but of course not necessarily
9133    a constant, and not necessarily converted into the appropriate
9134    type, leaving that up to the caller (so as to avoid that overhead
9135    if the decls being looked at are different anyway).
9136
9137    If the size cannot be determined (e.g. an adjustable array),
9138    an ERROR_MARK node is returned for the size.  Otherwise, the
9139    size returned is valid, not necessarily a constant, and not
9140    necessarily converted into the appropriate type as with the
9141    offset.
9142
9143    Note that the offset and size expressions are expressed in the
9144    base storage units (usually bits) rather than in the units of
9145    the type of the decl, because two decls with different types
9146    might overlap but with apparently non-overlapping array offsets,
9147    whereas converting the array offsets to consistant offsets will
9148    reveal the overlap.  */
9149
9150 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9151 static void
9152 ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
9153                            tree *size, tree t)
9154 {
9155   /* The default path is to report a nonexistant decl.  */
9156   *decl = NULL_TREE;
9157
9158   if (t == NULL_TREE)
9159     return;
9160
9161   switch (TREE_CODE (t))
9162     {
9163     case ERROR_MARK:
9164     case IDENTIFIER_NODE:
9165     case INTEGER_CST:
9166     case REAL_CST:
9167     case COMPLEX_CST:
9168     case STRING_CST:
9169     case CONST_DECL:
9170     case PLUS_EXPR:
9171     case MINUS_EXPR:
9172     case MULT_EXPR:
9173     case TRUNC_DIV_EXPR:
9174     case CEIL_DIV_EXPR:
9175     case FLOOR_DIV_EXPR:
9176     case ROUND_DIV_EXPR:
9177     case TRUNC_MOD_EXPR:
9178     case CEIL_MOD_EXPR:
9179     case FLOOR_MOD_EXPR:
9180     case ROUND_MOD_EXPR:
9181     case RDIV_EXPR:
9182     case EXACT_DIV_EXPR:
9183     case FIX_TRUNC_EXPR:
9184     case FIX_CEIL_EXPR:
9185     case FIX_FLOOR_EXPR:
9186     case FIX_ROUND_EXPR:
9187     case FLOAT_EXPR:
9188     case EXPON_EXPR:
9189     case NEGATE_EXPR:
9190     case MIN_EXPR:
9191     case MAX_EXPR:
9192     case ABS_EXPR:
9193     case FFS_EXPR:
9194     case LSHIFT_EXPR:
9195     case RSHIFT_EXPR:
9196     case LROTATE_EXPR:
9197     case RROTATE_EXPR:
9198     case BIT_IOR_EXPR:
9199     case BIT_XOR_EXPR:
9200     case BIT_AND_EXPR:
9201     case BIT_ANDTC_EXPR:
9202     case BIT_NOT_EXPR:
9203     case TRUTH_ANDIF_EXPR:
9204     case TRUTH_ORIF_EXPR:
9205     case TRUTH_AND_EXPR:
9206     case TRUTH_OR_EXPR:
9207     case TRUTH_XOR_EXPR:
9208     case TRUTH_NOT_EXPR:
9209     case LT_EXPR:
9210     case LE_EXPR:
9211     case GT_EXPR:
9212     case GE_EXPR:
9213     case EQ_EXPR:
9214     case NE_EXPR:
9215     case COMPLEX_EXPR:
9216     case CONJ_EXPR:
9217     case REALPART_EXPR:
9218     case IMAGPART_EXPR:
9219     case LABEL_EXPR:
9220     case COMPONENT_REF:
9221     case COMPOUND_EXPR:
9222     case ADDR_EXPR:
9223       return;
9224
9225     case VAR_DECL:
9226     case PARM_DECL:
9227       *decl = t;
9228       *offset = bitsize_zero_node;
9229       *size = TYPE_SIZE (TREE_TYPE (t));
9230       return;
9231
9232     case ARRAY_REF:
9233       {
9234         tree array = TREE_OPERAND (t, 0);
9235         tree element = TREE_OPERAND (t, 1);
9236         tree init_offset;
9237
9238         if ((array == NULL_TREE)
9239             || (element == NULL_TREE))
9240           {
9241             *decl = error_mark_node;
9242             return;
9243           }
9244
9245         ffecom_tree_canonize_ref_ (decl, &init_offset, size,
9246                                    array);
9247         if ((*decl == NULL_TREE)
9248             || (*decl == error_mark_node))
9249           return;
9250
9251         /* Calculate ((element - base) * NBBY) + init_offset.  */
9252         *offset = fold (build (MINUS_EXPR, TREE_TYPE (element),
9253                                element,
9254                                TYPE_MIN_VALUE (TYPE_DOMAIN
9255                                                (TREE_TYPE (array)))));
9256
9257         *offset = size_binop (MULT_EXPR,
9258                               convert (bitsizetype, *offset),
9259                               TYPE_SIZE (TREE_TYPE (TREE_TYPE (array))));
9260
9261         *offset = size_binop (PLUS_EXPR, init_offset, *offset);
9262
9263         *size = TYPE_SIZE (TREE_TYPE (t));
9264         return;
9265       }
9266
9267     case INDIRECT_REF:
9268
9269       /* Most of this code is to handle references to COMMON.  And so
9270          far that is useful only for calling library functions, since
9271          external (user) functions might reference common areas.  But
9272          even calling an external function, it's worthwhile to decode
9273          COMMON references because if not storing into COMMON, we don't
9274          want COMMON-based arguments to gratuitously force use of a
9275          temporary.  */
9276
9277       *size = TYPE_SIZE (TREE_TYPE (t));
9278
9279       ffecom_tree_canonize_ptr_ (decl, offset,
9280                                  TREE_OPERAND (t, 0));
9281
9282       return;
9283
9284     case CONVERT_EXPR:
9285     case NOP_EXPR:
9286     case MODIFY_EXPR:
9287     case NON_LVALUE_EXPR:
9288     case RESULT_DECL:
9289     case FIELD_DECL:
9290     case COND_EXPR:             /* More cases than we can handle. */
9291     case SAVE_EXPR:
9292     case REFERENCE_EXPR:
9293     case PREDECREMENT_EXPR:
9294     case PREINCREMENT_EXPR:
9295     case POSTDECREMENT_EXPR:
9296     case POSTINCREMENT_EXPR:
9297     case CALL_EXPR:
9298     default:
9299       *decl = error_mark_node;
9300       return;
9301     }
9302 }
9303 #endif
9304
9305 /* Do divide operation appropriate to type of operands.  */
9306
9307 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9308 static tree
9309 ffecom_tree_divide_ (tree tree_type, tree left, tree right,
9310                      tree dest_tree, ffebld dest, bool *dest_used,
9311                      tree hook)
9312 {
9313   if ((left == error_mark_node)
9314       || (right == error_mark_node))
9315     return error_mark_node;
9316
9317   switch (TREE_CODE (tree_type))
9318     {
9319     case INTEGER_TYPE:
9320       return ffecom_2 (TRUNC_DIV_EXPR, tree_type,
9321                        left,
9322                        right);
9323
9324     case COMPLEX_TYPE:
9325       if (! optimize_size)
9326         return ffecom_2 (RDIV_EXPR, tree_type,
9327                          left,
9328                          right);
9329       {
9330         ffecomGfrt ix;
9331
9332         if (TREE_TYPE (tree_type)
9333             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9334           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9335         else
9336           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9337
9338         left = ffecom_1 (ADDR_EXPR,
9339                          build_pointer_type (TREE_TYPE (left)),
9340                          left);
9341         left = build_tree_list (NULL_TREE, left);
9342         right = ffecom_1 (ADDR_EXPR,
9343                           build_pointer_type (TREE_TYPE (right)),
9344                           right);
9345         right = build_tree_list (NULL_TREE, right);
9346         TREE_CHAIN (left) = right;
9347
9348         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9349                              ffecom_gfrt_kindtype (ix),
9350                              ffe_is_f2c_library (),
9351                              tree_type,
9352                              left,
9353                              dest_tree, dest, dest_used,
9354                              NULL_TREE, TRUE, hook);
9355       }
9356       break;
9357
9358     case RECORD_TYPE:
9359       {
9360         ffecomGfrt ix;
9361
9362         if (TREE_TYPE (TYPE_FIELDS (tree_type))
9363             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9364           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9365         else
9366           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9367
9368         left = ffecom_1 (ADDR_EXPR,
9369                          build_pointer_type (TREE_TYPE (left)),
9370                          left);
9371         left = build_tree_list (NULL_TREE, left);
9372         right = ffecom_1 (ADDR_EXPR,
9373                           build_pointer_type (TREE_TYPE (right)),
9374                           right);
9375         right = build_tree_list (NULL_TREE, right);
9376         TREE_CHAIN (left) = right;
9377
9378         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9379                              ffecom_gfrt_kindtype (ix),
9380                              ffe_is_f2c_library (),
9381                              tree_type,
9382                              left,
9383                              dest_tree, dest, dest_used,
9384                              NULL_TREE, TRUE, hook);
9385       }
9386       break;
9387
9388     default:
9389       return ffecom_2 (RDIV_EXPR, tree_type,
9390                        left,
9391                        right);
9392     }
9393 }
9394
9395 #endif
9396 /* Build type info for non-dummy variable.  */
9397
9398 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9399 static tree
9400 ffecom_type_localvar_ (ffesymbol s, ffeinfoBasictype bt,
9401                        ffeinfoKindtype kt)
9402 {
9403   tree type;
9404   ffebld dl;
9405   ffebld dim;
9406   tree lowt;
9407   tree hight;
9408
9409   type = ffecom_tree_type[bt][kt];
9410   if (bt == FFEINFO_basictypeCHARACTER)
9411     {
9412       hight = build_int_2 (ffesymbol_size (s), 0);
9413       TREE_TYPE (hight) = ffecom_f2c_ftnlen_type_node;
9414
9415       type
9416         = build_array_type
9417           (type,
9418            build_range_type (ffecom_f2c_ftnlen_type_node,
9419                              ffecom_f2c_ftnlen_one_node,
9420                              hight));
9421       type = ffecom_check_size_overflow_ (s, type, FALSE);
9422     }
9423
9424   for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
9425     {
9426       if (type == error_mark_node)
9427         break;
9428
9429       dim = ffebld_head (dl);
9430       assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
9431
9432       if (ffebld_left (dim) == NULL)
9433         lowt = integer_one_node;
9434       else
9435         lowt = ffecom_expr (ffebld_left (dim));
9436
9437       if (TREE_CODE (lowt) != INTEGER_CST)
9438         lowt = variable_size (lowt);
9439
9440       assert (ffebld_right (dim) != NULL);
9441       hight = ffecom_expr (ffebld_right (dim));
9442
9443       if (TREE_CODE (hight) != INTEGER_CST)
9444         hight = variable_size (hight);
9445
9446       type = build_array_type (type,
9447                                build_range_type (ffecom_integer_type_node,
9448                                                  lowt, hight));
9449       type = ffecom_check_size_overflow_ (s, type, FALSE);
9450     }
9451
9452   return type;
9453 }
9454
9455 #endif
9456 /* Build Namelist type.  */
9457
9458 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9459 static tree
9460 ffecom_type_namelist_ ()
9461 {
9462   static tree type = NULL_TREE;
9463
9464   if (type == NULL_TREE)
9465     {
9466       static tree namefield, varsfield, nvarsfield;
9467       tree vardesctype;
9468
9469       vardesctype = ffecom_type_vardesc_ ();
9470
9471       type = make_node (RECORD_TYPE);
9472
9473       vardesctype = build_pointer_type (build_pointer_type (vardesctype));
9474
9475       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9476                                      string_type_node);
9477       varsfield = ffecom_decl_field (type, namefield, "vars", vardesctype);
9478       nvarsfield = ffecom_decl_field (type, varsfield, "nvars",
9479                                       integer_type_node);
9480
9481       TYPE_FIELDS (type) = namefield;
9482       layout_type (type);
9483
9484       ggc_add_tree_root (&type, 1);
9485     }
9486
9487   return type;
9488 }
9489
9490 #endif
9491
9492 /* Build Vardesc type.  */
9493
9494 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9495 static tree
9496 ffecom_type_vardesc_ ()
9497 {
9498   static tree type = NULL_TREE;
9499   static tree namefield, addrfield, dimsfield, typefield;
9500
9501   if (type == NULL_TREE)
9502     {
9503       type = make_node (RECORD_TYPE);
9504
9505       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9506                                      string_type_node);
9507       addrfield = ffecom_decl_field (type, namefield, "addr",
9508                                      string_type_node);
9509       dimsfield = ffecom_decl_field (type, addrfield, "dims",
9510                                      ffecom_f2c_ptr_to_ftnlen_type_node);
9511       typefield = ffecom_decl_field (type, dimsfield, "type",
9512                                      integer_type_node);
9513
9514       TYPE_FIELDS (type) = namefield;
9515       layout_type (type);
9516
9517       ggc_add_tree_root (&type, 1);
9518     }
9519
9520   return type;
9521 }
9522
9523 #endif
9524
9525 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9526 static tree
9527 ffecom_vardesc_ (ffebld expr)
9528 {
9529   ffesymbol s;
9530
9531   assert (ffebld_op (expr) == FFEBLD_opSYMTER);
9532   s = ffebld_symter (expr);
9533
9534   if (ffesymbol_hook (s).vardesc_tree == NULL_TREE)
9535     {
9536       int i;
9537       tree vardesctype = ffecom_type_vardesc_ ();
9538       tree var;
9539       tree nameinit;
9540       tree dimsinit;
9541       tree addrinit;
9542       tree typeinit;
9543       tree field;
9544       tree varinits;
9545       int yes;
9546       static int mynumber = 0;
9547
9548       yes = suspend_momentary ();
9549
9550       var = build_decl (VAR_DECL,
9551                         ffecom_get_invented_identifier ("__g77_vardesc_%d",
9552                                                         mynumber++),
9553                         vardesctype);
9554       TREE_STATIC (var) = 1;
9555       DECL_INITIAL (var) = error_mark_node;
9556
9557       var = start_decl (var, FALSE);
9558
9559       /* Process inits.  */
9560
9561       nameinit = ffecom_build_f2c_string_ ((i = strlen (ffesymbol_text (s)))
9562                                            + 1,
9563                                            ffesymbol_text (s));
9564       TREE_TYPE (nameinit)
9565         = build_type_variant
9566         (build_array_type
9567          (char_type_node,
9568           build_range_type (integer_type_node,
9569                             integer_one_node,
9570                             build_int_2 (i, 0))),
9571          1, 0);
9572       TREE_CONSTANT (nameinit) = 1;
9573       TREE_STATIC (nameinit) = 1;
9574       nameinit = ffecom_1 (ADDR_EXPR,
9575                            build_pointer_type (TREE_TYPE (nameinit)),
9576                            nameinit);
9577
9578       addrinit = ffecom_arg_ptr_to_expr (expr, &typeinit);
9579
9580       dimsinit = ffecom_vardesc_dims_ (s);
9581
9582       if (typeinit == NULL_TREE)
9583         {
9584           ffeinfoBasictype bt = ffesymbol_basictype (s);
9585           ffeinfoKindtype kt = ffesymbol_kindtype (s);
9586           int tc = ffecom_f2c_typecode (bt, kt);
9587
9588           assert (tc != -1);
9589           typeinit = build_int_2 (tc, (tc < 0) ? -1 : 0);
9590         }
9591       else
9592         typeinit = ffecom_1 (NEGATE_EXPR, TREE_TYPE (typeinit), typeinit);
9593
9594       varinits = build_tree_list ((field = TYPE_FIELDS (vardesctype)),
9595                                   nameinit);
9596       TREE_CHAIN (varinits) = build_tree_list ((field = TREE_CHAIN (field)),
9597                                                addrinit);
9598       TREE_CHAIN (TREE_CHAIN (varinits))
9599         = build_tree_list ((field = TREE_CHAIN (field)), dimsinit);
9600       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits)))
9601         = build_tree_list ((field = TREE_CHAIN (field)), typeinit);
9602
9603       varinits = build (CONSTRUCTOR, vardesctype, NULL_TREE, varinits);
9604       TREE_CONSTANT (varinits) = 1;
9605       TREE_STATIC (varinits) = 1;
9606
9607       finish_decl (var, varinits, FALSE);
9608
9609       var = ffecom_1 (ADDR_EXPR, build_pointer_type (vardesctype), var);
9610
9611       resume_momentary (yes);
9612
9613       ffesymbol_hook (s).vardesc_tree = var;
9614     }
9615
9616   return ffesymbol_hook (s).vardesc_tree;
9617 }
9618
9619 #endif
9620 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9621 static tree
9622 ffecom_vardesc_array_ (ffesymbol s)
9623 {
9624   ffebld b;
9625   tree list;
9626   tree item = NULL_TREE;
9627   tree var;
9628   int i;
9629   int yes;
9630   static int mynumber = 0;
9631
9632   for (i = 0, list = NULL_TREE, b = ffesymbol_namelist (s);
9633        b != NULL;
9634        b = ffebld_trail (b), ++i)
9635     {
9636       tree t;
9637
9638       t = ffecom_vardesc_ (ffebld_head (b));
9639
9640       if (list == NULL_TREE)
9641         list = item = build_tree_list (NULL_TREE, t);
9642       else
9643         {
9644           TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9645           item = TREE_CHAIN (item);
9646         }
9647     }
9648
9649   yes = suspend_momentary ();
9650
9651   item = build_array_type (build_pointer_type (ffecom_type_vardesc_ ()),
9652                            build_range_type (integer_type_node,
9653                                              integer_one_node,
9654                                              build_int_2 (i, 0)));
9655   list = build (CONSTRUCTOR, item, NULL_TREE, list);
9656   TREE_CONSTANT (list) = 1;
9657   TREE_STATIC (list) = 1;
9658
9659   var = ffecom_get_invented_identifier ("__g77_vardesc_array_%d", mynumber++);
9660   var = build_decl (VAR_DECL, var, item);
9661   TREE_STATIC (var) = 1;
9662   DECL_INITIAL (var) = error_mark_node;
9663   var = start_decl (var, FALSE);
9664   finish_decl (var, list, FALSE);
9665
9666   resume_momentary (yes);
9667
9668   return var;
9669 }
9670
9671 #endif
9672 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9673 static tree
9674 ffecom_vardesc_dims_ (ffesymbol s)
9675 {
9676   if (ffesymbol_dims (s) == NULL)
9677     return convert (ffecom_f2c_ptr_to_ftnlen_type_node,
9678                     integer_zero_node);
9679
9680   {
9681     ffebld b;
9682     ffebld e;
9683     tree list;
9684     tree backlist;
9685     tree item = NULL_TREE;
9686     tree var;
9687     int yes;
9688     tree numdim;
9689     tree numelem;
9690     tree baseoff = NULL_TREE;
9691     static int mynumber = 0;
9692
9693     numdim = build_int_2 ((int) ffesymbol_rank (s), 0);
9694     TREE_TYPE (numdim) = ffecom_f2c_ftnlen_type_node;
9695
9696     numelem = ffecom_expr (ffesymbol_arraysize (s));
9697     TREE_TYPE (numelem) = ffecom_f2c_ftnlen_type_node;
9698
9699     list = NULL_TREE;
9700     backlist = NULL_TREE;
9701     for (b = ffesymbol_dims (s), e = ffesymbol_extents (s);
9702          b != NULL;
9703          b = ffebld_trail (b), e = ffebld_trail (e))
9704       {
9705         tree t;
9706         tree low;
9707         tree back;
9708
9709         if (ffebld_trail (b) == NULL)
9710           t = NULL_TREE;
9711         else
9712           {
9713             t = convert (ffecom_f2c_ftnlen_type_node,
9714                          ffecom_expr (ffebld_head (e)));
9715
9716             if (list == NULL_TREE)
9717               list = item = build_tree_list (NULL_TREE, t);
9718             else
9719               {
9720                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9721                 item = TREE_CHAIN (item);
9722               }
9723           }
9724
9725         if (ffebld_left (ffebld_head (b)) == NULL)
9726           low = ffecom_integer_one_node;
9727         else
9728           low = ffecom_expr (ffebld_left (ffebld_head (b)));
9729         low = convert (ffecom_f2c_ftnlen_type_node, low);
9730
9731         back = build_tree_list (low, t);
9732         TREE_CHAIN (back) = backlist;
9733         backlist = back;
9734       }
9735
9736     for (item = backlist; item != NULL_TREE; item = TREE_CHAIN (item))
9737       {
9738         if (TREE_VALUE (item) == NULL_TREE)
9739           baseoff = TREE_PURPOSE (item);
9740         else
9741           baseoff = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
9742                               TREE_PURPOSE (item),
9743                               ffecom_2 (MULT_EXPR,
9744                                         ffecom_f2c_ftnlen_type_node,
9745                                         TREE_VALUE (item),
9746                                         baseoff));
9747       }
9748
9749     /* backlist now dead, along with all TREE_PURPOSEs on it.  */
9750
9751     baseoff = build_tree_list (NULL_TREE, baseoff);
9752     TREE_CHAIN (baseoff) = list;
9753
9754     numelem = build_tree_list (NULL_TREE, numelem);
9755     TREE_CHAIN (numelem) = baseoff;
9756
9757     numdim = build_tree_list (NULL_TREE, numdim);
9758     TREE_CHAIN (numdim) = numelem;
9759
9760     yes = suspend_momentary ();
9761
9762     item = build_array_type (ffecom_f2c_ftnlen_type_node,
9763                              build_range_type (integer_type_node,
9764                                                integer_zero_node,
9765                                                build_int_2
9766                                                ((int) ffesymbol_rank (s)
9767                                                 + 2, 0)));
9768     list = build (CONSTRUCTOR, item, NULL_TREE, numdim);
9769     TREE_CONSTANT (list) = 1;
9770     TREE_STATIC (list) = 1;
9771
9772     var = ffecom_get_invented_identifier ("__g77_dims_%d", mynumber++);
9773     var = build_decl (VAR_DECL, var, item);
9774     TREE_STATIC (var) = 1;
9775     DECL_INITIAL (var) = error_mark_node;
9776     var = start_decl (var, FALSE);
9777     finish_decl (var, list, FALSE);
9778
9779     var = ffecom_1 (ADDR_EXPR, build_pointer_type (item), var);
9780
9781     resume_momentary (yes);
9782
9783     return var;
9784   }
9785 }
9786
9787 #endif
9788 /* Essentially does a "fold (build1 (code, type, node))" while checking
9789    for certain housekeeping things.
9790
9791    NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
9792    ffecom_1_fn instead.  */
9793
9794 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9795 tree
9796 ffecom_1 (enum tree_code code, tree type, tree node)
9797 {
9798   tree item;
9799
9800   if ((node == error_mark_node)
9801       || (type == error_mark_node))
9802     return error_mark_node;
9803
9804   if (code == ADDR_EXPR)
9805     {
9806       if (!mark_addressable (node))
9807         assert ("can't mark_addressable this node!" == NULL);
9808     }
9809
9810   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9811     {
9812       tree realtype;
9813
9814     case REALPART_EXPR:
9815       item = build (COMPONENT_REF, type, node, TYPE_FIELDS (TREE_TYPE (node)));
9816       break;
9817
9818     case IMAGPART_EXPR:
9819       item = build (COMPONENT_REF, type, node, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node))));
9820       break;
9821
9822
9823     case NEGATE_EXPR:
9824       if (TREE_CODE (type) != RECORD_TYPE)
9825         {
9826           item = build1 (code, type, node);
9827           break;
9828         }
9829       node = ffecom_stabilize_aggregate_ (node);
9830       realtype = TREE_TYPE (TYPE_FIELDS (type));
9831       item =
9832         ffecom_2 (COMPLEX_EXPR, type,
9833                   ffecom_1 (NEGATE_EXPR, realtype,
9834                             ffecom_1 (REALPART_EXPR, realtype,
9835                                       node)),
9836                   ffecom_1 (NEGATE_EXPR, realtype,
9837                             ffecom_1 (IMAGPART_EXPR, realtype,
9838                                       node)));
9839       break;
9840
9841     default:
9842       item = build1 (code, type, node);
9843       break;
9844     }
9845
9846   if (TREE_SIDE_EFFECTS (node))
9847     TREE_SIDE_EFFECTS (item) = 1;
9848   if ((code == ADDR_EXPR) && staticp (node))
9849     TREE_CONSTANT (item) = 1;
9850   return fold (item);
9851 }
9852 #endif
9853
9854 /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
9855    handles TREE_CODE (node) == FUNCTION_DECL.  In particular,
9856    does not set TREE_ADDRESSABLE (because calling an inline
9857    function does not mean the function needs to be separately
9858    compiled).  */
9859
9860 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9861 tree
9862 ffecom_1_fn (tree node)
9863 {
9864   tree item;
9865   tree type;
9866
9867   if (node == error_mark_node)
9868     return error_mark_node;
9869
9870   type = build_type_variant (TREE_TYPE (node),
9871                              TREE_READONLY (node),
9872                              TREE_THIS_VOLATILE (node));
9873   item = build1 (ADDR_EXPR,
9874                  build_pointer_type (type), node);
9875   if (TREE_SIDE_EFFECTS (node))
9876     TREE_SIDE_EFFECTS (item) = 1;
9877   if (staticp (node))
9878     TREE_CONSTANT (item) = 1;
9879   return fold (item);
9880 }
9881 #endif
9882
9883 /* Essentially does a "fold (build (code, type, node1, node2))" while
9884    checking for certain housekeeping things.  */
9885
9886 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9887 tree
9888 ffecom_2 (enum tree_code code, tree type, tree node1,
9889           tree node2)
9890 {
9891   tree item;
9892
9893   if ((node1 == error_mark_node)
9894       || (node2 == error_mark_node)
9895       || (type == error_mark_node))
9896     return error_mark_node;
9897
9898   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9899     {
9900       tree a, b, c, d, realtype;
9901
9902     case CONJ_EXPR:
9903       assert ("no CONJ_EXPR support yet" == NULL);
9904       return error_mark_node;
9905
9906     case COMPLEX_EXPR:
9907       item = build_tree_list (TYPE_FIELDS (type), node1);
9908       TREE_CHAIN (item) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), node2);
9909       item = build (CONSTRUCTOR, type, NULL_TREE, item);
9910       break;
9911
9912     case PLUS_EXPR:
9913       if (TREE_CODE (type) != RECORD_TYPE)
9914         {
9915           item = build (code, type, node1, node2);
9916           break;
9917         }
9918       node1 = ffecom_stabilize_aggregate_ (node1);
9919       node2 = ffecom_stabilize_aggregate_ (node2);
9920       realtype = TREE_TYPE (TYPE_FIELDS (type));
9921       item =
9922         ffecom_2 (COMPLEX_EXPR, type,
9923                   ffecom_2 (PLUS_EXPR, realtype,
9924                             ffecom_1 (REALPART_EXPR, realtype,
9925                                       node1),
9926                             ffecom_1 (REALPART_EXPR, realtype,
9927                                       node2)),
9928                   ffecom_2 (PLUS_EXPR, realtype,
9929                             ffecom_1 (IMAGPART_EXPR, realtype,
9930                                       node1),
9931                             ffecom_1 (IMAGPART_EXPR, realtype,
9932                                       node2)));
9933       break;
9934
9935     case MINUS_EXPR:
9936       if (TREE_CODE (type) != RECORD_TYPE)
9937         {
9938           item = build (code, type, node1, node2);
9939           break;
9940         }
9941       node1 = ffecom_stabilize_aggregate_ (node1);
9942       node2 = ffecom_stabilize_aggregate_ (node2);
9943       realtype = TREE_TYPE (TYPE_FIELDS (type));
9944       item =
9945         ffecom_2 (COMPLEX_EXPR, type,
9946                   ffecom_2 (MINUS_EXPR, realtype,
9947                             ffecom_1 (REALPART_EXPR, realtype,
9948                                       node1),
9949                             ffecom_1 (REALPART_EXPR, realtype,
9950                                       node2)),
9951                   ffecom_2 (MINUS_EXPR, realtype,
9952                             ffecom_1 (IMAGPART_EXPR, realtype,
9953                                       node1),
9954                             ffecom_1 (IMAGPART_EXPR, realtype,
9955                                       node2)));
9956       break;
9957
9958     case MULT_EXPR:
9959       if (TREE_CODE (type) != RECORD_TYPE)
9960         {
9961           item = build (code, type, node1, node2);
9962           break;
9963         }
9964       node1 = ffecom_stabilize_aggregate_ (node1);
9965       node2 = ffecom_stabilize_aggregate_ (node2);
9966       realtype = TREE_TYPE (TYPE_FIELDS (type));
9967       a = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9968                                node1));
9969       b = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9970                                node1));
9971       c = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9972                                node2));
9973       d = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9974                                node2));
9975       item =
9976         ffecom_2 (COMPLEX_EXPR, type,
9977                   ffecom_2 (MINUS_EXPR, realtype,
9978                             ffecom_2 (MULT_EXPR, realtype,
9979                                       a,
9980                                       c),
9981                             ffecom_2 (MULT_EXPR, realtype,
9982                                       b,
9983                                       d)),
9984                   ffecom_2 (PLUS_EXPR, realtype,
9985                             ffecom_2 (MULT_EXPR, realtype,
9986                                       a,
9987                                       d),
9988                             ffecom_2 (MULT_EXPR, realtype,
9989                                       c,
9990                                       b)));
9991       break;
9992
9993     case EQ_EXPR:
9994       if ((TREE_CODE (node1) != RECORD_TYPE)
9995           && (TREE_CODE (node2) != RECORD_TYPE))
9996         {
9997           item = build (code, type, node1, node2);
9998           break;
9999         }
10000       assert (TREE_CODE (node1) == RECORD_TYPE);
10001       assert (TREE_CODE (node2) == RECORD_TYPE);
10002       node1 = ffecom_stabilize_aggregate_ (node1);
10003       node2 = ffecom_stabilize_aggregate_ (node2);
10004       realtype = TREE_TYPE (TYPE_FIELDS (type));
10005       item =
10006         ffecom_2 (TRUTH_ANDIF_EXPR, type,
10007                   ffecom_2 (code, type,
10008                             ffecom_1 (REALPART_EXPR, realtype,
10009                                       node1),
10010                             ffecom_1 (REALPART_EXPR, realtype,
10011                                       node2)),
10012                   ffecom_2 (code, type,
10013                             ffecom_1 (IMAGPART_EXPR, realtype,
10014                                       node1),
10015                             ffecom_1 (IMAGPART_EXPR, realtype,
10016                                       node2)));
10017       break;
10018
10019     case NE_EXPR:
10020       if ((TREE_CODE (node1) != RECORD_TYPE)
10021           && (TREE_CODE (node2) != RECORD_TYPE))
10022         {
10023           item = build (code, type, node1, node2);
10024           break;
10025         }
10026       assert (TREE_CODE (node1) == RECORD_TYPE);
10027       assert (TREE_CODE (node2) == RECORD_TYPE);
10028       node1 = ffecom_stabilize_aggregate_ (node1);
10029       node2 = ffecom_stabilize_aggregate_ (node2);
10030       realtype = TREE_TYPE (TYPE_FIELDS (type));
10031       item =
10032         ffecom_2 (TRUTH_ORIF_EXPR, type,
10033                   ffecom_2 (code, type,
10034                             ffecom_1 (REALPART_EXPR, realtype,
10035                                       node1),
10036                             ffecom_1 (REALPART_EXPR, realtype,
10037                                       node2)),
10038                   ffecom_2 (code, type,
10039                             ffecom_1 (IMAGPART_EXPR, realtype,
10040                                       node1),
10041                             ffecom_1 (IMAGPART_EXPR, realtype,
10042                                       node2)));
10043       break;
10044
10045     default:
10046       item = build (code, type, node1, node2);
10047       break;
10048     }
10049
10050   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2))
10051     TREE_SIDE_EFFECTS (item) = 1;
10052   return fold (item);
10053 }
10054
10055 #endif
10056 /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
10057
10058    ffesymbol s;  // the ENTRY point itself
10059    if (ffecom_2pass_advise_entrypoint(s))
10060        // the ENTRY point has been accepted
10061
10062    Does whatever compiler needs to do when it learns about the entrypoint,
10063    like determine the return type of the master function, count the
10064    number of entrypoints, etc.  Returns FALSE if the return type is
10065    not compatible with the return type(s) of other entrypoint(s).
10066
10067    NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
10068    later (after _finish_progunit) be called with the same entrypoint(s)
10069    as passed to this fn for which TRUE was returned.
10070
10071    03-Jan-92  JCB  2.0
10072       Return FALSE if the return type conflicts with previous entrypoints.  */
10073
10074 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10075 bool
10076 ffecom_2pass_advise_entrypoint (ffesymbol entry)
10077 {
10078   ffebld list;                  /* opITEM. */
10079   ffebld mlist;                 /* opITEM. */
10080   ffebld plist;                 /* opITEM. */
10081   ffebld arg;                   /* ffebld_head(opITEM). */
10082   ffebld item;                  /* opITEM. */
10083   ffesymbol s;                  /* ffebld_symter(arg). */
10084   ffeinfoBasictype bt = ffesymbol_basictype (entry);
10085   ffeinfoKindtype kt = ffesymbol_kindtype (entry);
10086   ffetargetCharacterSize size = ffesymbol_size (entry);
10087   bool ok;
10088
10089   if (ffecom_num_entrypoints_ == 0)
10090     {                           /* First entrypoint, make list of main
10091                                    arglist's dummies. */
10092       assert (ffecom_primary_entry_ != NULL);
10093
10094       ffecom_master_bt_ = ffesymbol_basictype (ffecom_primary_entry_);
10095       ffecom_master_kt_ = ffesymbol_kindtype (ffecom_primary_entry_);
10096       ffecom_master_size_ = ffesymbol_size (ffecom_primary_entry_);
10097
10098       for (plist = NULL, list = ffesymbol_dummyargs (ffecom_primary_entry_);
10099            list != NULL;
10100            list = ffebld_trail (list))
10101         {
10102           arg = ffebld_head (list);
10103           if (ffebld_op (arg) != FFEBLD_opSYMTER)
10104             continue;           /* Alternate return or some such thing. */
10105           item = ffebld_new_item (arg, NULL);
10106           if (plist == NULL)
10107             ffecom_master_arglist_ = item;
10108           else
10109             ffebld_set_trail (plist, item);
10110           plist = item;
10111         }
10112     }
10113
10114   /* If necessary, scan entry arglist for alternate returns.  Do this scan
10115      apparently redundantly (it's done below to UNIONize the arglists) so
10116      that we don't complain about RETURN 1 if an offending ENTRY is the only
10117      one with an alternate return.  */
10118
10119   if (!ffecom_is_altreturning_)
10120     {
10121       for (list = ffesymbol_dummyargs (entry);
10122            list != NULL;
10123            list = ffebld_trail (list))
10124         {
10125           arg = ffebld_head (list);
10126           if (ffebld_op (arg) == FFEBLD_opSTAR)
10127             {
10128               ffecom_is_altreturning_ = TRUE;
10129               break;
10130             }
10131         }
10132     }
10133
10134   /* Now check type compatibility. */
10135
10136   switch (ffecom_master_bt_)
10137     {
10138     case FFEINFO_basictypeNONE:
10139       ok = (bt != FFEINFO_basictypeCHARACTER);
10140       break;
10141
10142     case FFEINFO_basictypeCHARACTER:
10143       ok
10144         = (bt == FFEINFO_basictypeCHARACTER)
10145         && (kt == ffecom_master_kt_)
10146         && (size == ffecom_master_size_);
10147       break;
10148
10149     case FFEINFO_basictypeANY:
10150       return FALSE;             /* Just don't bother. */
10151
10152     default:
10153       if (bt == FFEINFO_basictypeCHARACTER)
10154         {
10155           ok = FALSE;
10156           break;
10157         }
10158       ok = TRUE;
10159       if ((bt != ffecom_master_bt_) || (kt != ffecom_master_kt_))
10160         {
10161           ffecom_master_bt_ = FFEINFO_basictypeNONE;
10162           ffecom_master_kt_ = FFEINFO_kindtypeNONE;
10163         }
10164       break;
10165     }
10166
10167   if (!ok)
10168     {
10169       ffebad_start (FFEBAD_ENTRY_CONFLICTS);
10170       ffest_ffebad_here_current_stmt (0);
10171       ffebad_finish ();
10172       return FALSE;             /* Can't handle entrypoint. */
10173     }
10174
10175   /* Entrypoint type compatible with previous types. */
10176
10177   ++ffecom_num_entrypoints_;
10178
10179   /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
10180
10181   for (list = ffesymbol_dummyargs (entry);
10182        list != NULL;
10183        list = ffebld_trail (list))
10184     {
10185       arg = ffebld_head (list);
10186       if (ffebld_op (arg) != FFEBLD_opSYMTER)
10187         continue;               /* Alternate return or some such thing. */
10188       s = ffebld_symter (arg);
10189       for (plist = NULL, mlist = ffecom_master_arglist_;
10190            mlist != NULL;
10191            plist = mlist, mlist = ffebld_trail (mlist))
10192         {                       /* plist points to previous item for easy
10193                                    appending of arg. */
10194           if (ffebld_symter (ffebld_head (mlist)) == s)
10195             break;              /* Already have this arg in the master list. */
10196         }
10197       if (mlist != NULL)
10198         continue;               /* Already have this arg in the master list. */
10199
10200       /* Append this arg to the master list. */
10201
10202       item = ffebld_new_item (arg, NULL);
10203       if (plist == NULL)
10204         ffecom_master_arglist_ = item;
10205       else
10206         ffebld_set_trail (plist, item);
10207     }
10208
10209   return TRUE;
10210 }
10211
10212 #endif
10213 /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
10214
10215    ffesymbol s;  // the ENTRY point itself
10216    ffecom_2pass_do_entrypoint(s);
10217
10218    Does whatever compiler needs to do to make the entrypoint actually
10219    happen.  Must be called for each entrypoint after
10220    ffecom_finish_progunit is called.  */
10221
10222 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10223 void
10224 ffecom_2pass_do_entrypoint (ffesymbol entry)
10225 {
10226   static int mfn_num = 0;
10227   static int ent_num;
10228
10229   if (mfn_num != ffecom_num_fns_)
10230     {                           /* First entrypoint for this program unit. */
10231       ent_num = 1;
10232       mfn_num = ffecom_num_fns_;
10233       ffecom_do_entry_ (ffecom_primary_entry_, 0);
10234     }
10235   else
10236     ++ent_num;
10237
10238   --ffecom_num_entrypoints_;
10239
10240   ffecom_do_entry_ (entry, ent_num);
10241 }
10242
10243 #endif
10244
10245 /* Essentially does a "fold (build (code, type, node1, node2))" while
10246    checking for certain housekeeping things.  Always sets
10247    TREE_SIDE_EFFECTS.  */
10248
10249 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10250 tree
10251 ffecom_2s (enum tree_code code, tree type, tree node1,
10252            tree node2)
10253 {
10254   tree item;
10255
10256   if ((node1 == error_mark_node)
10257       || (node2 == error_mark_node)
10258       || (type == error_mark_node))
10259     return error_mark_node;
10260
10261   item = build (code, type, node1, node2);
10262   TREE_SIDE_EFFECTS (item) = 1;
10263   return fold (item);
10264 }
10265
10266 #endif
10267 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10268    checking for certain housekeeping things.  */
10269
10270 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10271 tree
10272 ffecom_3 (enum tree_code code, tree type, tree node1,
10273           tree node2, tree node3)
10274 {
10275   tree item;
10276
10277   if ((node1 == error_mark_node)
10278       || (node2 == error_mark_node)
10279       || (node3 == error_mark_node)
10280       || (type == error_mark_node))
10281     return error_mark_node;
10282
10283   item = build (code, type, node1, node2, node3);
10284   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2)
10285       || (node3 != NULL_TREE && TREE_SIDE_EFFECTS (node3)))
10286     TREE_SIDE_EFFECTS (item) = 1;
10287   return fold (item);
10288 }
10289
10290 #endif
10291 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10292    checking for certain housekeeping things.  Always sets
10293    TREE_SIDE_EFFECTS.  */
10294
10295 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10296 tree
10297 ffecom_3s (enum tree_code code, tree type, tree node1,
10298            tree node2, tree node3)
10299 {
10300   tree item;
10301
10302   if ((node1 == error_mark_node)
10303       || (node2 == error_mark_node)
10304       || (node3 == error_mark_node)
10305       || (type == error_mark_node))
10306     return error_mark_node;
10307
10308   item = build (code, type, node1, node2, node3);
10309   TREE_SIDE_EFFECTS (item) = 1;
10310   return fold (item);
10311 }
10312
10313 #endif
10314
10315 /* ffecom_arg_expr -- Transform argument expr into gcc tree
10316
10317    See use by ffecom_list_expr.
10318
10319    If expression is NULL, returns an integer zero tree.  If it is not
10320    a CHARACTER expression, returns whatever ffecom_expr
10321    returns and sets the length return value to NULL_TREE.  Otherwise
10322    generates code to evaluate the character expression, returns the proper
10323    pointer to the result, but does NOT set the length return value to a tree
10324    that specifies the length of the result.  (In other words, the length
10325    variable is always set to NULL_TREE, because a length is never passed.)
10326
10327    21-Dec-91  JCB  1.1
10328       Don't set returned length, since nobody needs it (yet; someday if
10329       we allow CHARACTER*(*) dummies to statement functions, we'll need
10330       it).  */
10331
10332 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10333 tree
10334 ffecom_arg_expr (ffebld expr, tree *length)
10335 {
10336   tree ign;
10337
10338   *length = NULL_TREE;
10339
10340   if (expr == NULL)
10341     return integer_zero_node;
10342
10343   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10344     return ffecom_expr (expr);
10345
10346   return ffecom_arg_ptr_to_expr (expr, &ign);
10347 }
10348
10349 #endif
10350 /* Transform expression into constant argument-pointer-to-expression tree.
10351
10352    If the expression can be transformed into a argument-pointer-to-expression
10353    tree that is constant, that is done, and the tree returned.  Else
10354    NULL_TREE is returned.
10355
10356    That way, a caller can attempt to provide compile-time initialization
10357    of a variable and, if that fails, *then* choose to start a new block
10358    and resort to using temporaries, as appropriate.  */
10359
10360 tree
10361 ffecom_arg_ptr_to_const_expr (ffebld expr, tree *length)
10362 {
10363   if (! expr)
10364     return integer_zero_node;
10365
10366   if (ffebld_op (expr) == FFEBLD_opANY)
10367     {
10368       if (length)
10369         *length = error_mark_node;
10370       return error_mark_node;
10371     }
10372
10373   if (ffebld_arity (expr) == 0
10374       && (ffebld_op (expr) != FFEBLD_opSYMTER
10375           || ffebld_where (expr) == FFEINFO_whereCOMMON
10376           || ffebld_where (expr) == FFEINFO_whereGLOBAL
10377           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10378     {
10379       tree t;
10380
10381       t = ffecom_arg_ptr_to_expr (expr, length);
10382       assert (TREE_CONSTANT (t));
10383       assert (! length || TREE_CONSTANT (*length));
10384       return t;
10385     }
10386
10387   if (length
10388       && ffebld_size (expr) != FFETARGET_charactersizeNONE)
10389     *length = build_int_2 (ffebld_size (expr), 0);
10390   else if (length)
10391     *length = NULL_TREE;
10392   return NULL_TREE;
10393 }
10394
10395 /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
10396
10397    See use by ffecom_list_ptr_to_expr.
10398
10399    If expression is NULL, returns an integer zero tree.  If it is not
10400    a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10401    returns and sets the length return value to NULL_TREE.  Otherwise
10402    generates code to evaluate the character expression, returns the proper
10403    pointer to the result, AND sets the length return value to a tree that
10404    specifies the length of the result.
10405
10406    If the length argument is NULL, this is a slightly special
10407    case of building a FORMAT expression, that is, an expression that
10408    will be used at run time without regard to length.  For the current
10409    implementation, which uses the libf2c library, this means it is nice
10410    to append a null byte to the end of the expression, where feasible,
10411    to make sure any diagnostic about the FORMAT string terminates at
10412    some useful point.
10413
10414    For now, treat %REF(char-expr) as the same as char-expr with a NULL
10415    length argument.  This might even be seen as a feature, if a null
10416    byte can always be appended.  */
10417
10418 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10419 tree
10420 ffecom_arg_ptr_to_expr (ffebld expr, tree *length)
10421 {
10422   tree item;
10423   tree ign_length;
10424   ffecomConcatList_ catlist;
10425
10426   if (length != NULL)
10427     *length = NULL_TREE;
10428
10429   if (expr == NULL)
10430     return integer_zero_node;
10431
10432   switch (ffebld_op (expr))
10433     {
10434     case FFEBLD_opPERCENT_VAL:
10435       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10436         return ffecom_expr (ffebld_left (expr));
10437       {
10438         tree temp_exp;
10439         tree temp_length;
10440
10441         temp_exp = ffecom_arg_ptr_to_expr (ffebld_left (expr), &temp_length);
10442         if (temp_exp == error_mark_node)
10443           return error_mark_node;
10444
10445         return ffecom_1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (temp_exp)),
10446                          temp_exp);
10447       }
10448
10449     case FFEBLD_opPERCENT_REF:
10450       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10451         return ffecom_ptr_to_expr (ffebld_left (expr));
10452       if (length != NULL)
10453         {
10454           ign_length = NULL_TREE;
10455           length = &ign_length;
10456         }
10457       expr = ffebld_left (expr);
10458       break;
10459
10460     case FFEBLD_opPERCENT_DESCR:
10461       switch (ffeinfo_basictype (ffebld_info (expr)))
10462         {
10463 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10464         case FFEINFO_basictypeHOLLERITH:
10465 #endif
10466         case FFEINFO_basictypeCHARACTER:
10467           break;                /* Passed by descriptor anyway. */
10468
10469         default:
10470           item = ffecom_ptr_to_expr (expr);
10471           if (item != error_mark_node)
10472             *length = TYPE_SIZE (TREE_TYPE (TREE_TYPE (item)));
10473           break;
10474         }
10475       break;
10476
10477     default:
10478       break;
10479     }
10480
10481 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10482   if ((ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeHOLLERITH)
10483       && (length != NULL))
10484     {                           /* Pass Hollerith by descriptor. */
10485       ffetargetHollerith h;
10486
10487       assert (ffebld_op (expr) == FFEBLD_opCONTER);
10488       h = ffebld_cu_val_hollerith (ffebld_constant_union
10489                                    (ffebld_conter (expr)));
10490       *length
10491         = build_int_2 (h.length, 0);
10492       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10493     }
10494 #endif
10495
10496   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10497     return ffecom_ptr_to_expr (expr);
10498
10499   assert (ffeinfo_kindtype (ffebld_info (expr))
10500           == FFEINFO_kindtypeCHARACTER1);
10501
10502   while (ffebld_op (expr) == FFEBLD_opPAREN)
10503     expr = ffebld_left (expr);
10504
10505   catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
10506   switch (ffecom_concat_list_count_ (catlist))
10507     {
10508     case 0:                     /* Shouldn't happen, but in case it does... */
10509       if (length != NULL)
10510         {
10511           *length = ffecom_f2c_ftnlen_zero_node;
10512           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10513         }
10514       ffecom_concat_list_kill_ (catlist);
10515       return null_pointer_node;
10516
10517     case 1:                     /* The (fairly) easy case. */
10518       if (length == NULL)
10519         ffecom_char_args_with_null_ (&item, &ign_length,
10520                                      ffecom_concat_list_expr_ (catlist, 0));
10521       else
10522         ffecom_char_args_ (&item, length,
10523                            ffecom_concat_list_expr_ (catlist, 0));
10524       ffecom_concat_list_kill_ (catlist);
10525       assert (item != NULL_TREE);
10526       return item;
10527
10528     default:                    /* Must actually concatenate things. */
10529       break;
10530     }
10531
10532   {
10533     int count = ffecom_concat_list_count_ (catlist);
10534     int i;
10535     tree lengths;
10536     tree items;
10537     tree length_array;
10538     tree item_array;
10539     tree citem;
10540     tree clength;
10541     tree temporary;
10542     tree num;
10543     tree known_length;
10544     ffetargetCharacterSize sz;
10545
10546     sz = ffecom_concat_list_maxlen_ (catlist);
10547     /* ~~Kludge! */
10548     assert (sz != FFETARGET_charactersizeNONE);
10549
10550 #ifdef HOHO
10551     length_array
10552       = lengths
10553       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
10554                              FFETARGET_charactersizeNONE, count, TRUE);
10555     item_array
10556       = items
10557       = ffecom_push_tempvar (ffecom_f2c_address_type_node,
10558                              FFETARGET_charactersizeNONE, count, TRUE);
10559     temporary = ffecom_push_tempvar (char_type_node,
10560                                      sz, -1, TRUE);
10561 #else
10562     {
10563       tree hook;
10564
10565       hook = ffebld_nonter_hook (expr);
10566       assert (hook);
10567       assert (TREE_CODE (hook) == TREE_VEC);
10568       assert (TREE_VEC_LENGTH (hook) == 3);
10569       length_array = lengths = TREE_VEC_ELT (hook, 0);
10570       item_array = items = TREE_VEC_ELT (hook, 1);
10571       temporary = TREE_VEC_ELT (hook, 2);
10572     }
10573 #endif
10574
10575     known_length = ffecom_f2c_ftnlen_zero_node;
10576
10577     for (i = 0; i < count; ++i)
10578       {
10579         if ((i == count)
10580             && (length == NULL))
10581           ffecom_char_args_with_null_ (&citem, &clength,
10582                                        ffecom_concat_list_expr_ (catlist, i));
10583         else
10584           ffecom_char_args_ (&citem, &clength,
10585                              ffecom_concat_list_expr_ (catlist, i));
10586         if ((citem == error_mark_node)
10587             || (clength == error_mark_node))
10588           {
10589             ffecom_concat_list_kill_ (catlist);
10590             *length = error_mark_node;
10591             return error_mark_node;
10592           }
10593
10594         items
10595           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
10596                       ffecom_modify (void_type_node,
10597                                      ffecom_2 (ARRAY_REF,
10598                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
10599                                                item_array,
10600                                                build_int_2 (i, 0)),
10601                                      citem),
10602                       items);
10603         clength = ffecom_save_tree (clength);
10604         if (length != NULL)
10605           known_length
10606             = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
10607                         known_length,
10608                         clength);
10609         lengths
10610           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
10611                       ffecom_modify (void_type_node,
10612                                      ffecom_2 (ARRAY_REF,
10613                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
10614                                                length_array,
10615                                                build_int_2 (i, 0)),
10616                                      clength),
10617                       lengths);
10618       }
10619
10620     temporary = ffecom_1 (ADDR_EXPR,
10621                           build_pointer_type (TREE_TYPE (temporary)),
10622                           temporary);
10623
10624     item = build_tree_list (NULL_TREE, temporary);
10625     TREE_CHAIN (item)
10626       = build_tree_list (NULL_TREE,
10627                          ffecom_1 (ADDR_EXPR,
10628                                    build_pointer_type (TREE_TYPE (items)),
10629                                    items));
10630     TREE_CHAIN (TREE_CHAIN (item))
10631       = build_tree_list (NULL_TREE,
10632                          ffecom_1 (ADDR_EXPR,
10633                                    build_pointer_type (TREE_TYPE (lengths)),
10634                                    lengths));
10635     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
10636       = build_tree_list
10637         (NULL_TREE,
10638          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
10639                    convert (ffecom_f2c_ftnlen_type_node,
10640                             build_int_2 (count, 0))));
10641     num = build_int_2 (sz, 0);
10642     TREE_TYPE (num) = ffecom_f2c_ftnlen_type_node;
10643     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item))))
10644       = build_tree_list (NULL_TREE, num);
10645
10646     item = ffecom_call_gfrt (FFECOM_gfrtCAT, item, NULL_TREE);
10647     TREE_SIDE_EFFECTS (item) = 1;
10648     item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (temporary),
10649                      item,
10650                      temporary);
10651
10652     if (length != NULL)
10653       *length = known_length;
10654   }
10655
10656   ffecom_concat_list_kill_ (catlist);
10657   assert (item != NULL_TREE);
10658   return item;
10659 }
10660
10661 #endif
10662 /* Generate call to run-time function.
10663
10664    The first arg is the GNU Fortran Run-Time function index, the second
10665    arg is the list of arguments to pass to it.  Returned is the expression
10666    (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
10667    result (which may be void).  */
10668
10669 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10670 tree
10671 ffecom_call_gfrt (ffecomGfrt ix, tree args, tree hook)
10672 {
10673   return ffecom_call_ (ffecom_gfrt_tree_ (ix),
10674                        ffecom_gfrt_kindtype (ix),
10675                        ffe_is_f2c_library () && ffecom_gfrt_complex_[ix],
10676                        NULL_TREE, args, NULL_TREE, NULL,
10677                        NULL, NULL_TREE, TRUE, hook);
10678 }
10679 #endif
10680
10681 /* Transform constant-union to tree.  */
10682
10683 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10684 tree
10685 ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt,
10686                       ffeinfoKindtype kt, tree tree_type)
10687 {
10688   tree item;
10689
10690   switch (bt)
10691     {
10692     case FFEINFO_basictypeINTEGER:
10693       {
10694         int val;
10695
10696         switch (kt)
10697           {
10698 #if FFETARGET_okINTEGER1
10699           case FFEINFO_kindtypeINTEGER1:
10700             val = ffebld_cu_val_integer1 (*cu);
10701             break;
10702 #endif
10703
10704 #if FFETARGET_okINTEGER2
10705           case FFEINFO_kindtypeINTEGER2:
10706             val = ffebld_cu_val_integer2 (*cu);
10707             break;
10708 #endif
10709
10710 #if FFETARGET_okINTEGER3
10711           case FFEINFO_kindtypeINTEGER3:
10712             val = ffebld_cu_val_integer3 (*cu);
10713             break;
10714 #endif
10715
10716 #if FFETARGET_okINTEGER4
10717           case FFEINFO_kindtypeINTEGER4:
10718             val = ffebld_cu_val_integer4 (*cu);
10719             break;
10720 #endif
10721
10722           default:
10723             assert ("bad INTEGER constant kind type" == NULL);
10724             /* Fall through. */
10725           case FFEINFO_kindtypeANY:
10726             return error_mark_node;
10727           }
10728         item = build_int_2 (val, (val < 0) ? -1 : 0);
10729         TREE_TYPE (item) = tree_type;
10730       }
10731       break;
10732
10733     case FFEINFO_basictypeLOGICAL:
10734       {
10735         int val;
10736
10737         switch (kt)
10738           {
10739 #if FFETARGET_okLOGICAL1
10740           case FFEINFO_kindtypeLOGICAL1:
10741             val = ffebld_cu_val_logical1 (*cu);
10742             break;
10743 #endif
10744
10745 #if FFETARGET_okLOGICAL2
10746           case FFEINFO_kindtypeLOGICAL2:
10747             val = ffebld_cu_val_logical2 (*cu);
10748             break;
10749 #endif
10750
10751 #if FFETARGET_okLOGICAL3
10752           case FFEINFO_kindtypeLOGICAL3:
10753             val = ffebld_cu_val_logical3 (*cu);
10754             break;
10755 #endif
10756
10757 #if FFETARGET_okLOGICAL4
10758           case FFEINFO_kindtypeLOGICAL4:
10759             val = ffebld_cu_val_logical4 (*cu);
10760             break;
10761 #endif
10762
10763           default:
10764             assert ("bad LOGICAL constant kind type" == NULL);
10765             /* Fall through. */
10766           case FFEINFO_kindtypeANY:
10767             return error_mark_node;
10768           }
10769         item = build_int_2 (val, (val < 0) ? -1 : 0);
10770         TREE_TYPE (item) = tree_type;
10771       }
10772       break;
10773
10774     case FFEINFO_basictypeREAL:
10775       {
10776         REAL_VALUE_TYPE val;
10777
10778         switch (kt)
10779           {
10780 #if FFETARGET_okREAL1
10781           case FFEINFO_kindtypeREAL1:
10782             val = ffetarget_value_real1 (ffebld_cu_val_real1 (*cu));
10783             break;
10784 #endif
10785
10786 #if FFETARGET_okREAL2
10787           case FFEINFO_kindtypeREAL2:
10788             val = ffetarget_value_real2 (ffebld_cu_val_real2 (*cu));
10789             break;
10790 #endif
10791
10792 #if FFETARGET_okREAL3
10793           case FFEINFO_kindtypeREAL3:
10794             val = ffetarget_value_real3 (ffebld_cu_val_real3 (*cu));
10795             break;
10796 #endif
10797
10798 #if FFETARGET_okREAL4
10799           case FFEINFO_kindtypeREAL4:
10800             val = ffetarget_value_real4 (ffebld_cu_val_real4 (*cu));
10801             break;
10802 #endif
10803
10804           default:
10805             assert ("bad REAL constant kind type" == NULL);
10806             /* Fall through. */
10807           case FFEINFO_kindtypeANY:
10808             return error_mark_node;
10809           }
10810         item = build_real (tree_type, val);
10811       }
10812       break;
10813
10814     case FFEINFO_basictypeCOMPLEX:
10815       {
10816         REAL_VALUE_TYPE real;
10817         REAL_VALUE_TYPE imag;
10818         tree el_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
10819
10820         switch (kt)
10821           {
10822 #if FFETARGET_okCOMPLEX1
10823           case FFEINFO_kindtypeREAL1:
10824             real = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).real);
10825             imag = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).imaginary);
10826             break;
10827 #endif
10828
10829 #if FFETARGET_okCOMPLEX2
10830           case FFEINFO_kindtypeREAL2:
10831             real = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).real);
10832             imag = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).imaginary);
10833             break;
10834 #endif
10835
10836 #if FFETARGET_okCOMPLEX3
10837           case FFEINFO_kindtypeREAL3:
10838             real = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).real);
10839             imag = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).imaginary);
10840             break;
10841 #endif
10842
10843 #if FFETARGET_okCOMPLEX4
10844           case FFEINFO_kindtypeREAL4:
10845             real = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).real);
10846             imag = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).imaginary);
10847             break;
10848 #endif
10849
10850           default:
10851             assert ("bad REAL constant kind type" == NULL);
10852             /* Fall through. */
10853           case FFEINFO_kindtypeANY:
10854             return error_mark_node;
10855           }
10856         item = ffecom_build_complex_constant_ (tree_type,
10857                                                build_real (el_type, real),
10858                                                build_real (el_type, imag));
10859       }
10860       break;
10861
10862     case FFEINFO_basictypeCHARACTER:
10863       {                         /* Happens only in DATA and similar contexts. */
10864         ffetargetCharacter1 val;
10865
10866         switch (kt)
10867           {
10868 #if FFETARGET_okCHARACTER1
10869           case FFEINFO_kindtypeLOGICAL1:
10870             val = ffebld_cu_val_character1 (*cu);
10871             break;
10872 #endif
10873
10874           default:
10875             assert ("bad CHARACTER constant kind type" == NULL);
10876             /* Fall through. */
10877           case FFEINFO_kindtypeANY:
10878             return error_mark_node;
10879           }
10880         item = build_string (ffetarget_length_character1 (val),
10881                              ffetarget_text_character1 (val));
10882         TREE_TYPE (item)
10883           = build_type_variant (build_array_type (char_type_node,
10884                                                   build_range_type
10885                                                   (integer_type_node,
10886                                                    integer_one_node,
10887                                                    build_int_2
10888                                                 (ffetarget_length_character1
10889                                                  (val), 0))),
10890                                 1, 0);
10891       }
10892       break;
10893
10894     case FFEINFO_basictypeHOLLERITH:
10895       {
10896         ffetargetHollerith h;
10897
10898         h = ffebld_cu_val_hollerith (*cu);
10899
10900         /* If not at least as wide as default INTEGER, widen it.  */
10901         if (h.length >= FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE)
10902           item = build_string (h.length, h.text);
10903         else
10904           {
10905             char str[FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE];
10906
10907             memcpy (str, h.text, h.length);
10908             memset (&str[h.length], ' ',
10909                     FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE
10910                     - h.length);
10911             item = build_string (FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE,
10912                                  str);
10913           }
10914         TREE_TYPE (item)
10915           = build_type_variant (build_array_type (char_type_node,
10916                                                   build_range_type
10917                                                   (integer_type_node,
10918                                                    integer_one_node,
10919                                                    build_int_2
10920                                                    (h.length, 0))),
10921                                 1, 0);
10922       }
10923       break;
10924
10925     case FFEINFO_basictypeTYPELESS:
10926       {
10927         ffetargetInteger1 ival;
10928         ffetargetTypeless tless;
10929         ffebad error;
10930
10931         tless = ffebld_cu_val_typeless (*cu);
10932         error = ffetarget_convert_integer1_typeless (&ival, tless);
10933         assert (error == FFEBAD);
10934
10935         item = build_int_2 ((int) ival, 0);
10936       }
10937       break;
10938
10939     default:
10940       assert ("not yet on constant type" == NULL);
10941       /* Fall through. */
10942     case FFEINFO_basictypeANY:
10943       return error_mark_node;
10944     }
10945
10946   TREE_CONSTANT (item) = 1;
10947
10948   return item;
10949 }
10950
10951 #endif
10952
10953 /* Transform expression into constant tree.
10954
10955    If the expression can be transformed into a tree that is constant,
10956    that is done, and the tree returned.  Else NULL_TREE is returned.
10957
10958    That way, a caller can attempt to provide compile-time initialization
10959    of a variable and, if that fails, *then* choose to start a new block
10960    and resort to using temporaries, as appropriate.  */
10961
10962 tree
10963 ffecom_const_expr (ffebld expr)
10964 {
10965   if (! expr)
10966     return integer_zero_node;
10967
10968   if (ffebld_op (expr) == FFEBLD_opANY)
10969     return error_mark_node;
10970
10971   if (ffebld_arity (expr) == 0
10972       && (ffebld_op (expr) != FFEBLD_opSYMTER
10973 #if NEWCOMMON
10974           /* ~~Enable once common/equivalence is handled properly?  */
10975           || ffebld_where (expr) == FFEINFO_whereCOMMON
10976 #endif
10977           || ffebld_where (expr) == FFEINFO_whereGLOBAL
10978           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10979     {
10980       tree t;
10981
10982       t = ffecom_expr (expr);
10983       assert (TREE_CONSTANT (t));
10984       return t;
10985     }
10986
10987   return NULL_TREE;
10988 }
10989
10990 /* Handy way to make a field in a struct/union.  */
10991
10992 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10993 tree
10994 ffecom_decl_field (tree context, tree prevfield,
10995                    const char *name, tree type)
10996 {
10997   tree field;
10998
10999   field = build_decl (FIELD_DECL, get_identifier (name), type);
11000   DECL_CONTEXT (field) = context;
11001   DECL_ALIGN (field) = 0;
11002   if (prevfield != NULL_TREE)
11003     TREE_CHAIN (prevfield) = field;
11004
11005   return field;
11006 }
11007
11008 #endif
11009
11010 void
11011 ffecom_close_include (FILE *f)
11012 {
11013 #if FFECOM_GCC_INCLUDE
11014   ffecom_close_include_ (f);
11015 #endif
11016 }
11017
11018 int
11019 ffecom_decode_include_option (char *spec)
11020 {
11021 #if FFECOM_GCC_INCLUDE
11022   return ffecom_decode_include_option_ (spec);
11023 #else
11024   return 1;
11025 #endif
11026 }
11027
11028 /* End a compound statement (block).  */
11029
11030 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11031 tree
11032 ffecom_end_compstmt (void)
11033 {
11034   return bison_rule_compstmt_ ();
11035 }
11036 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
11037
11038 /* ffecom_end_transition -- Perform end transition on all symbols
11039
11040    ffecom_end_transition();
11041
11042    Calls ffecom_sym_end_transition for each global and local symbol.  */
11043
11044 void
11045 ffecom_end_transition ()
11046 {
11047 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11048   ffebld item;
11049 #endif
11050
11051   if (ffe_is_ffedebug ())
11052     fprintf (dmpout, "; end_stmt_transition\n");
11053
11054 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11055   ffecom_list_blockdata_ = NULL;
11056   ffecom_list_common_ = NULL;
11057 #endif
11058
11059   ffesymbol_drive (ffecom_sym_end_transition);
11060   if (ffe_is_ffedebug ())
11061     {
11062       ffestorag_report ();
11063 #if FFECOM_targetCURRENT == FFECOM_targetFFE
11064       ffesymbol_report_all ();
11065 #endif
11066     }
11067
11068 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11069   ffecom_start_progunit_ ();
11070
11071   for (item = ffecom_list_blockdata_;
11072        item != NULL;
11073        item = ffebld_trail (item))
11074     {
11075       ffebld callee;
11076       ffesymbol s;
11077       tree dt;
11078       tree t;
11079       tree var;
11080       int yes;
11081       static int number = 0;
11082
11083       callee = ffebld_head (item);
11084       s = ffebld_symter (callee);
11085       t = ffesymbol_hook (s).decl_tree;
11086       if (t == NULL_TREE)
11087         {
11088           s = ffecom_sym_transform_ (s);
11089           t = ffesymbol_hook (s).decl_tree;
11090         }
11091
11092       yes = suspend_momentary ();
11093
11094       dt = build_pointer_type (TREE_TYPE (t));
11095
11096       var = build_decl (VAR_DECL,
11097                         ffecom_get_invented_identifier ("__g77_forceload_%d",
11098                                                         number++),
11099                         dt);
11100       DECL_EXTERNAL (var) = 0;
11101       TREE_STATIC (var) = 1;
11102       TREE_PUBLIC (var) = 0;
11103       DECL_INITIAL (var) = error_mark_node;
11104       TREE_USED (var) = 1;
11105
11106       var = start_decl (var, FALSE);
11107
11108       t = ffecom_1 (ADDR_EXPR, dt, t);
11109
11110       finish_decl (var, t, FALSE);
11111
11112       resume_momentary (yes);
11113     }
11114
11115   /* This handles any COMMON areas that weren't referenced but have, for
11116      example, important initial data.  */
11117
11118   for (item = ffecom_list_common_;
11119        item != NULL;
11120        item = ffebld_trail (item))
11121     ffecom_transform_common_ (ffebld_symter (ffebld_head (item)));
11122
11123   ffecom_list_common_ = NULL;
11124 #endif
11125 }
11126
11127 /* ffecom_exec_transition -- Perform exec transition on all symbols
11128
11129    ffecom_exec_transition();
11130
11131    Calls ffecom_sym_exec_transition for each global and local symbol.
11132    Make sure error updating not inhibited.  */
11133
11134 void
11135 ffecom_exec_transition ()
11136 {
11137   bool inhibited;
11138
11139   if (ffe_is_ffedebug ())
11140     fprintf (dmpout, "; exec_stmt_transition\n");
11141
11142   inhibited = ffebad_inhibit ();
11143   ffebad_set_inhibit (FALSE);
11144
11145   ffesymbol_drive (ffecom_sym_exec_transition); /* Don't retract! */
11146   ffeequiv_exec_transition ();  /* Handle all pending EQUIVALENCEs. */
11147   if (ffe_is_ffedebug ())
11148     {
11149       ffestorag_report ();
11150 #if FFECOM_targetCURRENT == FFECOM_targetFFE
11151       ffesymbol_report_all ();
11152 #endif
11153     }
11154
11155   if (inhibited)
11156     ffebad_set_inhibit (TRUE);
11157 }
11158
11159 /* Handle assignment statement.
11160
11161    Convert dest and source using ffecom_expr, then join them
11162    with an ASSIGN op and pass the whole thing to expand_expr_stmt.  */
11163
11164 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11165 void
11166 ffecom_expand_let_stmt (ffebld dest, ffebld source)
11167 {
11168   tree dest_tree;
11169   tree dest_length;
11170   tree source_tree;
11171   tree expr_tree;
11172
11173   if (ffeinfo_basictype (ffebld_info (dest)) != FFEINFO_basictypeCHARACTER)
11174     {
11175       bool dest_used;
11176       tree assign_temp;
11177
11178       /* This attempts to replicate the test below, but must not be
11179          true when the test below is false.  (Always err on the side
11180          of creating unused temporaries, to avoid ICEs.)  */
11181       if (ffebld_op (dest) != FFEBLD_opSYMTER
11182           || ((dest_tree = ffesymbol_hook (ffebld_symter (dest)).decl_tree)
11183               && (TREE_CODE (dest_tree) != VAR_DECL
11184                   || TREE_ADDRESSABLE (dest_tree))))
11185         {
11186           ffecom_prepare_expr_ (source, dest);
11187           dest_used = TRUE;
11188         }
11189       else
11190         {
11191           ffecom_prepare_expr_ (source, NULL);
11192           dest_used = FALSE;
11193         }
11194
11195       ffecom_prepare_expr_w (NULL_TREE, dest);
11196
11197       /* For COMPLEX assignment like C1=C2, if partial overlap is possible,
11198          create a temporary through which the assignment is to take place,
11199          since MODIFY_EXPR doesn't handle partial overlap properly.  */
11200       if (ffebld_basictype (dest) == FFEINFO_basictypeCOMPLEX
11201           && ffecom_possible_partial_overlap_ (dest, source))
11202         {
11203           assign_temp = ffecom_make_tempvar ("complex_let",
11204                                              ffecom_tree_type
11205                                              [ffebld_basictype (dest)]
11206                                              [ffebld_kindtype (dest)],
11207                                              FFETARGET_charactersizeNONE,
11208                                              -1);
11209         }
11210       else
11211         assign_temp = NULL_TREE;
11212
11213       ffecom_prepare_end ();
11214
11215       dest_tree = ffecom_expr_w (NULL_TREE, dest);
11216       if (dest_tree == error_mark_node)
11217         return;
11218
11219       if ((TREE_CODE (dest_tree) != VAR_DECL)
11220           || TREE_ADDRESSABLE (dest_tree))
11221         source_tree = ffecom_expr_ (source, dest_tree, dest, &dest_used,
11222                                     FALSE, FALSE);
11223       else
11224         {
11225           assert (! dest_used);
11226           dest_used = FALSE;
11227           source_tree = ffecom_expr (source);
11228         }
11229       if (source_tree == error_mark_node)
11230         return;
11231
11232       if (dest_used)
11233         expr_tree = source_tree;
11234       else if (assign_temp)
11235         {
11236 #ifdef MOVE_EXPR
11237           /* The back end understands a conceptual move (evaluate source;
11238              store into dest), so use that, in case it can determine
11239              that it is going to use, say, two registers as temporaries
11240              anyway.  So don't use the temp (and someday avoid generating
11241              it, once this code starts triggering regularly).  */
11242           expr_tree = ffecom_2s (MOVE_EXPR, void_type_node,
11243                                  dest_tree,
11244                                  source_tree);
11245 #else
11246           expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11247                                  assign_temp,
11248                                  source_tree);
11249           expand_expr_stmt (expr_tree);
11250           expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11251                                  dest_tree,
11252                                  assign_temp);
11253 #endif
11254         }
11255       else
11256         expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11257                                dest_tree,
11258                                source_tree);
11259
11260       expand_expr_stmt (expr_tree);
11261       return;
11262     }
11263
11264   ffecom_prepare_let_char_ (ffebld_size_known (dest), source);
11265   ffecom_prepare_expr_w (NULL_TREE, dest);
11266
11267   ffecom_prepare_end ();
11268
11269   ffecom_char_args_ (&dest_tree, &dest_length, dest);
11270   ffecom_let_char_ (dest_tree, dest_length, ffebld_size_known (dest),
11271                     source);
11272 }
11273
11274 #endif
11275 /* ffecom_expr -- Transform expr into gcc tree
11276
11277    tree t;
11278    ffebld expr;  // FFE expression.
11279    tree = ffecom_expr(expr);
11280
11281    Recursive descent on expr while making corresponding tree nodes and
11282    attaching type info and such.  */
11283
11284 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11285 tree
11286 ffecom_expr (ffebld expr)
11287 {
11288   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, FALSE, FALSE);
11289 }
11290
11291 #endif
11292 /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT.  */
11293
11294 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11295 tree
11296 ffecom_expr_assign (ffebld expr)
11297 {
11298   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
11299 }
11300
11301 #endif
11302 /* Like ffecom_expr_rw, but return tree usable for ASSIGN.  */
11303
11304 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11305 tree
11306 ffecom_expr_assign_w (ffebld expr)
11307 {
11308   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
11309 }
11310
11311 #endif
11312 /* Transform expr for use as into read/write tree and stabilize the
11313    reference.  Not for use on CHARACTER expressions.
11314
11315    Recursive descent on expr while making corresponding tree nodes and
11316    attaching type info and such.  */
11317
11318 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11319 tree
11320 ffecom_expr_rw (tree type, ffebld expr)
11321 {
11322   assert (expr != NULL);
11323   /* Different target types not yet supported.  */
11324   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
11325
11326   return stabilize_reference (ffecom_expr (expr));
11327 }
11328
11329 #endif
11330 /* Transform expr for use as into write tree and stabilize the
11331    reference.  Not for use on CHARACTER expressions.
11332
11333    Recursive descent on expr while making corresponding tree nodes and
11334    attaching type info and such.  */
11335
11336 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11337 tree
11338 ffecom_expr_w (tree type, ffebld expr)
11339 {
11340   assert (expr != NULL);
11341   /* Different target types not yet supported.  */
11342   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
11343
11344   return stabilize_reference (ffecom_expr (expr));
11345 }
11346
11347 #endif
11348 /* Do global stuff.  */
11349
11350 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11351 void
11352 ffecom_finish_compile ()
11353 {
11354   assert (ffecom_outer_function_decl_ == NULL_TREE);
11355   assert (current_function_decl == NULL_TREE);
11356
11357   ffeglobal_drive (ffecom_finish_global_);
11358 }
11359
11360 #endif
11361 /* Public entry point for front end to access finish_decl.  */
11362
11363 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11364 void
11365 ffecom_finish_decl (tree decl, tree init, bool is_top_level)
11366 {
11367   assert (!is_top_level);
11368   finish_decl (decl, init, FALSE);
11369 }
11370
11371 #endif
11372 /* Finish a program unit.  */
11373
11374 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11375 void
11376 ffecom_finish_progunit ()
11377 {
11378   ffecom_end_compstmt ();
11379
11380   ffecom_previous_function_decl_ = current_function_decl;
11381   ffecom_which_entrypoint_decl_ = NULL_TREE;
11382
11383   finish_function (0);
11384 }
11385
11386 #endif
11387
11388 /* Wrapper for get_identifier.  pattern is sprintf-like.  */
11389
11390 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11391 tree
11392 ffecom_get_invented_identifier (const char *pattern, ...)
11393 {
11394   tree decl;
11395   char *nam;
11396   va_list ap;
11397
11398   va_start (ap, pattern);
11399   if (vasprintf (&nam, pattern, ap) == 0)
11400     abort ();
11401   va_end (ap);
11402   decl = get_identifier (nam);
11403   free (nam);
11404   IDENTIFIER_INVENTED (decl) = 1;
11405   return decl;
11406 }
11407
11408 ffeinfoBasictype
11409 ffecom_gfrt_basictype (ffecomGfrt gfrt)
11410 {
11411   assert (gfrt < FFECOM_gfrt);
11412
11413   switch (ffecom_gfrt_type_[gfrt])
11414     {
11415     case FFECOM_rttypeVOID_:
11416     case FFECOM_rttypeVOIDSTAR_:
11417       return FFEINFO_basictypeNONE;
11418
11419     case FFECOM_rttypeFTNINT_:
11420       return FFEINFO_basictypeINTEGER;
11421
11422     case FFECOM_rttypeINTEGER_:
11423       return FFEINFO_basictypeINTEGER;
11424
11425     case FFECOM_rttypeLONGINT_:
11426       return FFEINFO_basictypeINTEGER;
11427
11428     case FFECOM_rttypeLOGICAL_:
11429       return FFEINFO_basictypeLOGICAL;
11430
11431     case FFECOM_rttypeREAL_F2C_:
11432     case FFECOM_rttypeREAL_GNU_:
11433       return FFEINFO_basictypeREAL;
11434
11435     case FFECOM_rttypeCOMPLEX_F2C_:
11436     case FFECOM_rttypeCOMPLEX_GNU_:
11437       return FFEINFO_basictypeCOMPLEX;
11438
11439     case FFECOM_rttypeDOUBLE_:
11440     case FFECOM_rttypeDOUBLEREAL_:
11441       return FFEINFO_basictypeREAL;
11442
11443     case FFECOM_rttypeDBLCMPLX_F2C_:
11444     case FFECOM_rttypeDBLCMPLX_GNU_:
11445       return FFEINFO_basictypeCOMPLEX;
11446
11447     case FFECOM_rttypeCHARACTER_:
11448       return FFEINFO_basictypeCHARACTER;
11449
11450     default:
11451       return FFEINFO_basictypeANY;
11452     }
11453 }
11454
11455 ffeinfoKindtype
11456 ffecom_gfrt_kindtype (ffecomGfrt gfrt)
11457 {
11458   assert (gfrt < FFECOM_gfrt);
11459
11460   switch (ffecom_gfrt_type_[gfrt])
11461     {
11462     case FFECOM_rttypeVOID_:
11463     case FFECOM_rttypeVOIDSTAR_:
11464       return FFEINFO_kindtypeNONE;
11465
11466     case FFECOM_rttypeFTNINT_:
11467       return FFEINFO_kindtypeINTEGER1;
11468
11469     case FFECOM_rttypeINTEGER_:
11470       return FFEINFO_kindtypeINTEGER1;
11471
11472     case FFECOM_rttypeLONGINT_:
11473       return FFEINFO_kindtypeINTEGER4;
11474
11475     case FFECOM_rttypeLOGICAL_:
11476       return FFEINFO_kindtypeLOGICAL1;
11477
11478     case FFECOM_rttypeREAL_F2C_:
11479     case FFECOM_rttypeREAL_GNU_:
11480       return FFEINFO_kindtypeREAL1;
11481
11482     case FFECOM_rttypeCOMPLEX_F2C_:
11483     case FFECOM_rttypeCOMPLEX_GNU_:
11484       return FFEINFO_kindtypeREAL1;
11485
11486     case FFECOM_rttypeDOUBLE_:
11487     case FFECOM_rttypeDOUBLEREAL_:
11488       return FFEINFO_kindtypeREAL2;
11489
11490     case FFECOM_rttypeDBLCMPLX_F2C_:
11491     case FFECOM_rttypeDBLCMPLX_GNU_:
11492       return FFEINFO_kindtypeREAL2;
11493
11494     case FFECOM_rttypeCHARACTER_:
11495       return FFEINFO_kindtypeCHARACTER1;
11496
11497     default:
11498       return FFEINFO_kindtypeANY;
11499     }
11500 }
11501
11502 void
11503 ffecom_init_0 ()
11504 {
11505   tree endlink;
11506   int i;
11507   int j;
11508   tree t;
11509   tree field;
11510   ffetype type;
11511   ffetype base_type;
11512   tree double_ftype_double;
11513   tree float_ftype_float;
11514   tree ldouble_ftype_ldouble;
11515   tree ffecom_tree_ptr_to_fun_type_void;
11516
11517   /* This block of code comes from the now-obsolete cktyps.c.  It checks
11518      whether the compiler environment is buggy in known ways, some of which
11519      would, if not explicitly checked here, result in subtle bugs in g77.  */
11520
11521   if (ffe_is_do_internal_checks ())
11522     {
11523       static char names[][12]
11524         =
11525       {"bar", "bletch", "foo", "foobar"};
11526       char *name;
11527       unsigned long ul;
11528       double fl;
11529
11530       name = bsearch ("foo", &names[0], ARRAY_SIZE (names), sizeof (names[0]),
11531                       (int (*)(const void *, const void *)) strcmp);
11532       if (name != (char *) &names[2])
11533         {
11534           assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
11535                   == NULL);
11536           abort ();
11537         }
11538
11539       ul = strtoul ("123456789", NULL, 10);
11540       if (ul != 123456789L)
11541         {
11542           assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\
11543  in proj.h" == NULL);
11544           abort ();
11545         }
11546
11547       fl = atof ("56.789");
11548       if ((fl < 56.788) || (fl > 56.79))
11549         {
11550           assert ("atof not type double, fix your #include <stdio.h>"
11551                   == NULL);
11552           abort ();
11553         }
11554     }
11555
11556 #if FFECOM_GCC_INCLUDE
11557   ffecom_initialize_char_syntax_ ();
11558 #endif
11559
11560   ffecom_outer_function_decl_ = NULL_TREE;
11561   current_function_decl = NULL_TREE;
11562   named_labels = NULL_TREE;
11563   current_binding_level = NULL_BINDING_LEVEL;
11564   free_binding_level = NULL_BINDING_LEVEL;
11565   /* Make the binding_level structure for global names.  */
11566   pushlevel (0);
11567   global_binding_level = current_binding_level;
11568   current_binding_level->prep_state = 2;
11569
11570   build_common_tree_nodes (1);
11571
11572   /* Define `int' and `char' first so that dbx will output them first.  */
11573   pushdecl (build_decl (TYPE_DECL, get_identifier ("int"),
11574                         integer_type_node));
11575   pushdecl (build_decl (TYPE_DECL, get_identifier ("char"),
11576                         char_type_node));
11577   pushdecl (build_decl (TYPE_DECL, get_identifier ("long int"),
11578                         long_integer_type_node));
11579   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"),
11580                         unsigned_type_node));
11581   pushdecl (build_decl (TYPE_DECL, get_identifier ("long unsigned int"),
11582                         long_unsigned_type_node));
11583   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long int"),
11584                         long_long_integer_type_node));
11585   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long unsigned int"),
11586                         long_long_unsigned_type_node));
11587   pushdecl (build_decl (TYPE_DECL, get_identifier ("short int"),
11588                         short_integer_type_node));
11589   pushdecl (build_decl (TYPE_DECL, get_identifier ("short unsigned int"),
11590                         short_unsigned_type_node));
11591
11592   /* Set the sizetype before we make other types.  This *should* be the
11593      first type we create.  */
11594
11595   set_sizetype
11596     (TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE))));
11597   ffecom_typesize_pointer_
11598     = TREE_INT_CST_LOW (TYPE_SIZE (sizetype)) / BITS_PER_UNIT;
11599
11600   build_common_tree_nodes_2 (0);
11601
11602   /* Define both `signed char' and `unsigned char'.  */
11603   pushdecl (build_decl (TYPE_DECL, get_identifier ("signed char"),
11604                         signed_char_type_node));
11605
11606   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"),
11607                         unsigned_char_type_node));
11608
11609   pushdecl (build_decl (TYPE_DECL, get_identifier ("float"),
11610                         float_type_node));
11611   pushdecl (build_decl (TYPE_DECL, get_identifier ("double"),
11612                         double_type_node));
11613   pushdecl (build_decl (TYPE_DECL, get_identifier ("long double"),
11614                         long_double_type_node));
11615
11616   /* For now, override what build_common_tree_nodes has done.  */
11617   complex_integer_type_node = ffecom_make_complex_type_ (integer_type_node);
11618   complex_float_type_node = ffecom_make_complex_type_ (float_type_node);
11619   complex_double_type_node = ffecom_make_complex_type_ (double_type_node);
11620   complex_long_double_type_node
11621     = ffecom_make_complex_type_ (long_double_type_node);
11622
11623   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex int"),
11624                         complex_integer_type_node));
11625   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex float"),
11626                         complex_float_type_node));
11627   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex double"),
11628                         complex_double_type_node));
11629   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex long double"),
11630                         complex_long_double_type_node));
11631
11632   pushdecl (build_decl (TYPE_DECL, get_identifier ("void"),
11633                         void_type_node));
11634   /* We are not going to have real types in C with less than byte alignment,
11635      so we might as well not have any types that claim to have it.  */
11636   TYPE_ALIGN (void_type_node) = BITS_PER_UNIT;
11637
11638   string_type_node = build_pointer_type (char_type_node);
11639
11640   ffecom_tree_fun_type_void
11641     = build_function_type (void_type_node, NULL_TREE);
11642
11643   ffecom_tree_ptr_to_fun_type_void
11644     = build_pointer_type (ffecom_tree_fun_type_void);
11645
11646   endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
11647
11648   float_ftype_float
11649     = build_function_type (float_type_node,
11650                            tree_cons (NULL_TREE, float_type_node, endlink));
11651
11652   double_ftype_double
11653     = build_function_type (double_type_node,
11654                            tree_cons (NULL_TREE, double_type_node, endlink));
11655
11656   ldouble_ftype_ldouble
11657     = build_function_type (long_double_type_node,
11658                            tree_cons (NULL_TREE, long_double_type_node,
11659                                       endlink));
11660
11661   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11662     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11663       {
11664         ffecom_tree_type[i][j] = NULL_TREE;
11665         ffecom_tree_fun_type[i][j] = NULL_TREE;
11666         ffecom_tree_ptr_to_fun_type[i][j] = NULL_TREE;
11667         ffecom_f2c_typecode_[i][j] = -1;
11668       }
11669
11670   /* Set up standard g77 types.  Note that INTEGER and LOGICAL are set
11671      to size FLOAT_TYPE_SIZE because they have to be the same size as
11672      REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
11673      Compiler options and other such stuff that change the ways these
11674      types are set should not affect this particular setup.  */
11675
11676   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1]
11677     = t = make_signed_type (FLOAT_TYPE_SIZE);
11678   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer"),
11679                         t));
11680   type = ffetype_new ();
11681   base_type = type;
11682   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER1,
11683                     type);
11684   ffetype_set_ams (type,
11685                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11686                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11687   ffetype_set_star (base_type,
11688                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11689                     type);
11690   ffetype_set_kind (base_type, 1, type);
11691   ffecom_typesize_integer1_ = ffetype_size (type);
11692   assert (ffetype_size (type) == sizeof (ffetargetInteger1));
11693
11694   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER1]
11695     = t = make_unsigned_type (FLOAT_TYPE_SIZE); /* HOLLERITH means unsigned. */
11696   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned"),
11697                         t));
11698
11699   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER2]
11700     = t = make_signed_type (CHAR_TYPE_SIZE);
11701   pushdecl (build_decl (TYPE_DECL, get_identifier ("byte"),
11702                         t));
11703   type = ffetype_new ();
11704   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER2,
11705                     type);
11706   ffetype_set_ams (type,
11707                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11708                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11709   ffetype_set_star (base_type,
11710                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11711                     type);
11712   ffetype_set_kind (base_type, 3, type);
11713   assert (ffetype_size (type) == sizeof (ffetargetInteger2));
11714
11715   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER2]
11716     = t = make_unsigned_type (CHAR_TYPE_SIZE);
11717   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned byte"),
11718                         t));
11719
11720   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER3]
11721     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11722   pushdecl (build_decl (TYPE_DECL, get_identifier ("word"),
11723                         t));
11724   type = ffetype_new ();
11725   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER3,
11726                     type);
11727   ffetype_set_ams (type,
11728                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11729                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11730   ffetype_set_star (base_type,
11731                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11732                     type);
11733   ffetype_set_kind (base_type, 6, type);
11734   assert (ffetype_size (type) == sizeof (ffetargetInteger3));
11735
11736   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER3]
11737     = t = make_unsigned_type (CHAR_TYPE_SIZE * 2);
11738   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned word"),
11739                         t));
11740
11741   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER4]
11742     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11743   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer4"),
11744                         t));
11745   type = ffetype_new ();
11746   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER4,
11747                     type);
11748   ffetype_set_ams (type,
11749                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11750                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11751   ffetype_set_star (base_type,
11752                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11753                     type);
11754   ffetype_set_kind (base_type, 2, type);
11755   assert (ffetype_size (type) == sizeof (ffetargetInteger4));
11756
11757   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER4]
11758     = t = make_unsigned_type (FLOAT_TYPE_SIZE * 2);
11759   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned4"),
11760                         t));
11761
11762 #if 0
11763   if (ffe_is_do_internal_checks ()
11764       && LONG_TYPE_SIZE != FLOAT_TYPE_SIZE
11765       && LONG_TYPE_SIZE != CHAR_TYPE_SIZE
11766       && LONG_TYPE_SIZE != SHORT_TYPE_SIZE
11767       && LONG_TYPE_SIZE != LONG_LONG_TYPE_SIZE)
11768     {
11769       fprintf (stderr, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n",
11770                LONG_TYPE_SIZE);
11771     }
11772 #endif
11773
11774   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL1]
11775     = t = make_signed_type (FLOAT_TYPE_SIZE);
11776   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical"),
11777                         t));
11778   type = ffetype_new ();
11779   base_type = type;
11780   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL1,
11781                     type);
11782   ffetype_set_ams (type,
11783                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11784                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11785   ffetype_set_star (base_type,
11786                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11787                     type);
11788   ffetype_set_kind (base_type, 1, type);
11789   assert (ffetype_size (type) == sizeof (ffetargetLogical1));
11790
11791   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL2]
11792     = t = make_signed_type (CHAR_TYPE_SIZE);
11793   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical2"),
11794                         t));
11795   type = ffetype_new ();
11796   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL2,
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, 3, type);
11805   assert (ffetype_size (type) == sizeof (ffetargetLogical2));
11806
11807   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL3]
11808     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11809   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical3"),
11810                         t));
11811   type = ffetype_new ();
11812   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL3,
11813                     type);
11814   ffetype_set_ams (type,
11815                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11816                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11817   ffetype_set_star (base_type,
11818                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11819                     type);
11820   ffetype_set_kind (base_type, 6, type);
11821   assert (ffetype_size (type) == sizeof (ffetargetLogical3));
11822
11823   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL4]
11824     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11825   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical4"),
11826                         t));
11827   type = ffetype_new ();
11828   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL4,
11829                     type);
11830   ffetype_set_ams (type,
11831                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11832                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11833   ffetype_set_star (base_type,
11834                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11835                     type);
11836   ffetype_set_kind (base_type, 2, type);
11837   assert (ffetype_size (type) == sizeof (ffetargetLogical4));
11838
11839   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11840     = t = make_node (REAL_TYPE);
11841   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE;
11842   pushdecl (build_decl (TYPE_DECL, get_identifier ("real"),
11843                         t));
11844   layout_type (t);
11845   type = ffetype_new ();
11846   base_type = type;
11847   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL1,
11848                     type);
11849   ffetype_set_ams (type,
11850                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11851                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11852   ffetype_set_star (base_type,
11853                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11854                     type);
11855   ffetype_set_kind (base_type, 1, type);
11856   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11857     = FFETARGET_f2cTYREAL;
11858   assert (ffetype_size (type) == sizeof (ffetargetReal1));
11859
11860   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREALDOUBLE]
11861     = t = make_node (REAL_TYPE);
11862   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE * 2;     /* Always twice REAL. */
11863   pushdecl (build_decl (TYPE_DECL, get_identifier ("double precision"),
11864                         t));
11865   layout_type (t);
11866   type = ffetype_new ();
11867   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
11868                     type);
11869   ffetype_set_ams (type,
11870                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11871                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11872   ffetype_set_star (base_type,
11873                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11874                     type);
11875   ffetype_set_kind (base_type, 2, type);
11876   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]
11877     = FFETARGET_f2cTYDREAL;
11878   assert (ffetype_size (type) == sizeof (ffetargetReal2));
11879
11880   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11881     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]);
11882   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex"),
11883                         t));
11884   type = ffetype_new ();
11885   base_type = type;
11886   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL1,
11887                     type);
11888   ffetype_set_ams (type,
11889                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11890                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11891   ffetype_set_star (base_type,
11892                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11893                     type);
11894   ffetype_set_kind (base_type, 1, type);
11895   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11896     = FFETARGET_f2cTYCOMPLEX;
11897   assert (ffetype_size (type) == sizeof (ffetargetComplex1));
11898
11899   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREALDOUBLE]
11900     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]);
11901   pushdecl (build_decl (TYPE_DECL, get_identifier ("double complex"),
11902                         t));
11903   type = ffetype_new ();
11904   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREALDOUBLE,
11905                     type);
11906   ffetype_set_ams (type,
11907                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11908                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11909   ffetype_set_star (base_type,
11910                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11911                     type);
11912   ffetype_set_kind (base_type, 2,
11913                     type);
11914   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL2]
11915     = FFETARGET_f2cTYDCOMPLEX;
11916   assert (ffetype_size (type) == sizeof (ffetargetComplex2));
11917
11918   /* Make function and ptr-to-function types for non-CHARACTER types. */
11919
11920   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11921     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11922       {
11923         if ((t = ffecom_tree_type[i][j]) != NULL_TREE)
11924           {
11925             if (i == FFEINFO_basictypeINTEGER)
11926               {
11927                 /* Figure out the smallest INTEGER type that can hold
11928                    a pointer on this machine. */
11929                 if (GET_MODE_SIZE (TYPE_MODE (t))
11930                     >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
11931                   {
11932                     if ((ffecom_pointer_kind_ == FFEINFO_kindtypeNONE)
11933                         || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type[i][ffecom_pointer_kind_]))
11934                             > GET_MODE_SIZE (TYPE_MODE (t))))
11935                       ffecom_pointer_kind_ = j;
11936                   }
11937               }
11938             else if (i == FFEINFO_basictypeCOMPLEX)
11939               t = void_type_node;
11940             /* For f2c compatibility, REAL functions are really
11941                implemented as DOUBLE PRECISION.  */
11942             else if ((i == FFEINFO_basictypeREAL)
11943                      && (j == FFEINFO_kindtypeREAL1))
11944               t = ffecom_tree_type
11945                 [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2];
11946
11947             t = ffecom_tree_fun_type[i][j] = build_function_type (t,
11948                                                                   NULL_TREE);
11949             ffecom_tree_ptr_to_fun_type[i][j] = build_pointer_type (t);
11950           }
11951       }
11952
11953   /* Set up pointer types.  */
11954
11955   if (ffecom_pointer_kind_ == FFEINFO_basictypeNONE)
11956     fatal ("no INTEGER type can hold a pointer on this configuration");
11957   else if (0 && ffe_is_do_internal_checks ())
11958     fprintf (stderr, "Pointer type kt=%d\n", ffecom_pointer_kind_);
11959   ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER,
11960                                   FFEINFO_kindtypeINTEGERDEFAULT),
11961                     7,
11962                     ffeinfo_type (FFEINFO_basictypeINTEGER,
11963                                   ffecom_pointer_kind_));
11964
11965   if (ffe_is_ugly_assign ())
11966     ffecom_label_kind_ = ffecom_pointer_kind_;  /* Require ASSIGN etc to this. */
11967   else
11968     ffecom_label_kind_ = FFEINFO_kindtypeINTEGERDEFAULT;
11969   if (0 && ffe_is_do_internal_checks ())
11970     fprintf (stderr, "Label type kt=%d\n", ffecom_label_kind_);
11971
11972   ffecom_integer_type_node
11973     = ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1];
11974   ffecom_integer_zero_node = convert (ffecom_integer_type_node,
11975                                       integer_zero_node);
11976   ffecom_integer_one_node = convert (ffecom_integer_type_node,
11977                                      integer_one_node);
11978
11979   /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
11980      Turns out that by TYLONG, runtime/libI77/lio.h really means
11981      "whatever size an ftnint is".  For consistency and sanity,
11982      com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
11983      all are INTEGER, which we also make out of whatever back-end
11984      integer type is FLOAT_TYPE_SIZE bits wide.  This change, from
11985      LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
11986      accommodate machines like the Alpha.  Note that this suggests
11987      f2c and libf2c are missing a distinction perhaps needed on
11988      some machines between "int" and "long int".  -- burley 0.5.5 950215 */
11989
11990   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, FLOAT_TYPE_SIZE,
11991                             FFETARGET_f2cTYLONG);
11992   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, SHORT_TYPE_SIZE,
11993                             FFETARGET_f2cTYSHORT);
11994   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, CHAR_TYPE_SIZE,
11995                             FFETARGET_f2cTYINT1);
11996   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, LONG_LONG_TYPE_SIZE,
11997                             FFETARGET_f2cTYQUAD);
11998   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, FLOAT_TYPE_SIZE,
11999                             FFETARGET_f2cTYLOGICAL);
12000   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, SHORT_TYPE_SIZE,
12001                             FFETARGET_f2cTYLOGICAL2);
12002   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, CHAR_TYPE_SIZE,
12003                             FFETARGET_f2cTYLOGICAL1);
12004   /* ~~~Not really such a type in libf2c, e.g. I/O support?  */
12005   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, LONG_LONG_TYPE_SIZE,
12006                             FFETARGET_f2cTYQUAD);
12007
12008   /* CHARACTER stuff is all special-cased, so it is not handled in the above
12009      loop.  CHARACTER items are built as arrays of unsigned char.  */
12010
12011   ffecom_tree_type[FFEINFO_basictypeCHARACTER]
12012     [FFEINFO_kindtypeCHARACTER1] = t = char_type_node;
12013   type = ffetype_new ();
12014   base_type = type;
12015   ffeinfo_set_type (FFEINFO_basictypeCHARACTER,
12016                     FFEINFO_kindtypeCHARACTER1,
12017                     type);
12018   ffetype_set_ams (type,
12019                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
12020                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
12021   ffetype_set_kind (base_type, 1, type);
12022   assert (ffetype_size (type)
12023           == sizeof (((ffetargetCharacter1) { 0, NULL }).text[0]));
12024
12025   ffecom_tree_fun_type[FFEINFO_basictypeCHARACTER]
12026     [FFEINFO_kindtypeCHARACTER1] = ffecom_tree_fun_type_void;
12027   ffecom_tree_ptr_to_fun_type[FFEINFO_basictypeCHARACTER]
12028     [FFEINFO_kindtypeCHARACTER1]
12029     = ffecom_tree_ptr_to_fun_type_void;
12030   ffecom_f2c_typecode_[FFEINFO_basictypeCHARACTER][FFEINFO_kindtypeCHARACTER1]
12031     = FFETARGET_f2cTYCHAR;
12032
12033   ffecom_f2c_typecode_[FFEINFO_basictypeANY][FFEINFO_kindtypeANY]
12034     = 0;
12035
12036   /* Make multi-return-value type and fields. */
12037
12038   ffecom_multi_type_node_ = make_node (UNION_TYPE);
12039
12040   field = NULL_TREE;
12041
12042   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
12043     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
12044       {
12045         char name[30];
12046
12047         if (ffecom_tree_type[i][j] == NULL_TREE)
12048           continue;             /* Not supported. */
12049         sprintf (&name[0], "bt_%s_kt_%s",
12050                  ffeinfo_basictype_string ((ffeinfoBasictype) i),
12051                  ffeinfo_kindtype_string ((ffeinfoKindtype) j));
12052         ffecom_multi_fields_[i][j] = build_decl (FIELD_DECL,
12053                                                  get_identifier (name),
12054                                                  ffecom_tree_type[i][j]);
12055         DECL_CONTEXT (ffecom_multi_fields_[i][j])
12056           = ffecom_multi_type_node_;
12057         DECL_ALIGN (ffecom_multi_fields_[i][j]) = 0;
12058         TREE_CHAIN (ffecom_multi_fields_[i][j]) = field;
12059         field = ffecom_multi_fields_[i][j];
12060       }
12061
12062   TYPE_FIELDS (ffecom_multi_type_node_) = field;
12063   layout_type (ffecom_multi_type_node_);
12064
12065   /* Subroutines usually return integer because they might have alternate
12066      returns. */
12067
12068   ffecom_tree_subr_type
12069     = build_function_type (integer_type_node, NULL_TREE);
12070   ffecom_tree_ptr_to_subr_type
12071     = build_pointer_type (ffecom_tree_subr_type);
12072   ffecom_tree_blockdata_type
12073     = build_function_type (void_type_node, NULL_TREE);
12074
12075   builtin_function ("__builtin_sqrtf", float_ftype_float,
12076                     BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrtf");
12077   builtin_function ("__builtin_fsqrt", double_ftype_double,
12078                     BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrt");
12079   builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble,
12080                     BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrtl");
12081   builtin_function ("__builtin_sinf", float_ftype_float,
12082                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sinf");
12083   builtin_function ("__builtin_sin", double_ftype_double,
12084                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sin");
12085   builtin_function ("__builtin_sinl", ldouble_ftype_ldouble,
12086                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sinl");
12087   builtin_function ("__builtin_cosf", float_ftype_float,
12088                     BUILT_IN_COS, BUILT_IN_NORMAL, "cosf");
12089   builtin_function ("__builtin_cos", double_ftype_double,
12090                     BUILT_IN_COS, BUILT_IN_NORMAL, "cos");
12091   builtin_function ("__builtin_cosl", ldouble_ftype_ldouble,
12092                     BUILT_IN_COS, BUILT_IN_NORMAL, "cosl");
12093
12094 #if BUILT_FOR_270
12095   pedantic_lvalues = FALSE;
12096 #endif
12097
12098   ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node,
12099                          FFECOM_f2cINTEGER,
12100                          "integer");
12101   ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node,
12102                          FFECOM_f2cADDRESS,
12103                          "address");
12104   ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node,
12105                          FFECOM_f2cREAL,
12106                          "real");
12107   ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node,
12108                          FFECOM_f2cDOUBLEREAL,
12109                          "doublereal");
12110   ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node,
12111                          FFECOM_f2cCOMPLEX,
12112                          "complex");
12113   ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node,
12114                          FFECOM_f2cDOUBLECOMPLEX,
12115                          "doublecomplex");
12116   ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node,
12117                          FFECOM_f2cLONGINT,
12118                          "longint");
12119   ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node,
12120                          FFECOM_f2cLOGICAL,
12121                          "logical");
12122   ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node,
12123                          FFECOM_f2cFLAG,
12124                          "flag");
12125   ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node,
12126                          FFECOM_f2cFTNLEN,
12127                          "ftnlen");
12128   ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node,
12129                          FFECOM_f2cFTNINT,
12130                          "ftnint");
12131
12132   ffecom_f2c_ftnlen_zero_node
12133     = convert (ffecom_f2c_ftnlen_type_node, integer_zero_node);
12134
12135   ffecom_f2c_ftnlen_one_node
12136     = convert (ffecom_f2c_ftnlen_type_node, integer_one_node);
12137
12138   ffecom_f2c_ftnlen_two_node = build_int_2 (2, 0);
12139   TREE_TYPE (ffecom_f2c_ftnlen_two_node) = ffecom_integer_type_node;
12140
12141   ffecom_f2c_ptr_to_ftnlen_type_node
12142     = build_pointer_type (ffecom_f2c_ftnlen_type_node);
12143
12144   ffecom_f2c_ptr_to_ftnint_type_node
12145     = build_pointer_type (ffecom_f2c_ftnint_type_node);
12146
12147   ffecom_f2c_ptr_to_integer_type_node
12148     = build_pointer_type (ffecom_f2c_integer_type_node);
12149
12150   ffecom_f2c_ptr_to_real_type_node
12151     = build_pointer_type (ffecom_f2c_real_type_node);
12152
12153   ffecom_float_zero_ = build_real (float_type_node, dconst0);
12154   ffecom_double_zero_ = build_real (double_type_node, dconst0);
12155   {
12156     REAL_VALUE_TYPE point_5;
12157
12158 #ifdef REAL_ARITHMETIC
12159     REAL_ARITHMETIC (point_5, RDIV_EXPR, dconst1, dconst2);
12160 #else
12161     point_5 = .5;
12162 #endif
12163     ffecom_float_half_ = build_real (float_type_node, point_5);
12164     ffecom_double_half_ = build_real (double_type_node, point_5);
12165   }
12166
12167   /* Do "extern int xargc;".  */
12168
12169   ffecom_tree_xargc_ = build_decl (VAR_DECL,
12170                                    get_identifier ("f__xargc"),
12171                                    integer_type_node);
12172   DECL_EXTERNAL (ffecom_tree_xargc_) = 1;
12173   TREE_STATIC (ffecom_tree_xargc_) = 1;
12174   TREE_PUBLIC (ffecom_tree_xargc_) = 1;
12175   ffecom_tree_xargc_ = start_decl (ffecom_tree_xargc_, FALSE);
12176   finish_decl (ffecom_tree_xargc_, NULL_TREE, FALSE);
12177
12178 #if 0   /* This is being fixed, and seems to be working now. */
12179   if ((FLOAT_TYPE_SIZE != 32)
12180       || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))) != 32))
12181     {
12182       warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,",
12183                (int) FLOAT_TYPE_SIZE);
12184       warning ("and pointers are %d bits wide, but g77 doesn't yet work",
12185           (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))));
12186       warning ("properly unless they all are 32 bits wide.");
12187       warning ("Please keep this in mind before you report bugs.  g77 should");
12188       warning ("support non-32-bit machines better as of version 0.6.");
12189     }
12190 #endif
12191
12192 #if 0   /* Code in ste.c that would crash has been commented out. */
12193   if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
12194       < TYPE_PRECISION (string_type_node))
12195     /* I/O will probably crash.  */
12196     warning ("configuration: char * holds %d bits, but ftnlen only %d",
12197              TYPE_PRECISION (string_type_node),
12198              TYPE_PRECISION (ffecom_f2c_ftnlen_type_node));
12199 #endif
12200
12201 #if 0   /* ASSIGN-related stuff has been changed to accommodate this. */
12202   if (TYPE_PRECISION (ffecom_integer_type_node)
12203       < TYPE_PRECISION (string_type_node))
12204     /* ASSIGN 10 TO I will crash.  */
12205     warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
12206  ASSIGN statement might fail",
12207              TYPE_PRECISION (string_type_node),
12208              TYPE_PRECISION (ffecom_integer_type_node));
12209 #endif
12210 }
12211
12212 #endif
12213 /* ffecom_init_2 -- Initialize
12214
12215    ffecom_init_2();  */
12216
12217 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12218 void
12219 ffecom_init_2 ()
12220 {
12221   assert (ffecom_outer_function_decl_ == NULL_TREE);
12222   assert (current_function_decl == NULL_TREE);
12223   assert (ffecom_which_entrypoint_decl_ == NULL_TREE);
12224
12225   ffecom_master_arglist_ = NULL;
12226   ++ffecom_num_fns_;
12227   ffecom_primary_entry_ = NULL;
12228   ffecom_is_altreturning_ = FALSE;
12229   ffecom_func_result_ = NULL_TREE;
12230   ffecom_multi_retval_ = NULL_TREE;
12231 }
12232
12233 #endif
12234 /* ffecom_list_expr -- Transform list of exprs into gcc tree
12235
12236    tree t;
12237    ffebld expr;  // FFE opITEM list.
12238    tree = ffecom_list_expr(expr);
12239
12240    List of actual args is transformed into corresponding gcc backend list.  */
12241
12242 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12243 tree
12244 ffecom_list_expr (ffebld expr)
12245 {
12246   tree list;
12247   tree *plist = &list;
12248   tree trail = NULL_TREE;       /* Append char length args here. */
12249   tree *ptrail = &trail;
12250   tree length;
12251
12252   while (expr != NULL)
12253     {
12254       tree texpr = ffecom_arg_expr (ffebld_head (expr), &length);
12255
12256       if (texpr == error_mark_node)
12257         return error_mark_node;
12258
12259       *plist = build_tree_list (NULL_TREE, texpr);
12260       plist = &TREE_CHAIN (*plist);
12261       expr = ffebld_trail (expr);
12262       if (length != NULL_TREE)
12263         {
12264           *ptrail = build_tree_list (NULL_TREE, length);
12265           ptrail = &TREE_CHAIN (*ptrail);
12266         }
12267     }
12268
12269   *plist = trail;
12270
12271   return list;
12272 }
12273
12274 #endif
12275 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
12276
12277    tree t;
12278    ffebld expr;  // FFE opITEM list.
12279    tree = ffecom_list_ptr_to_expr(expr);
12280
12281    List of actual args is transformed into corresponding gcc backend list for
12282    use in calling an external procedure (vs. a statement function).  */
12283
12284 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12285 tree
12286 ffecom_list_ptr_to_expr (ffebld expr)
12287 {
12288   tree list;
12289   tree *plist = &list;
12290   tree trail = NULL_TREE;       /* Append char length args here. */
12291   tree *ptrail = &trail;
12292   tree length;
12293
12294   while (expr != NULL)
12295     {
12296       tree texpr = ffecom_arg_ptr_to_expr (ffebld_head (expr), &length);
12297
12298       if (texpr == error_mark_node)
12299         return error_mark_node;
12300
12301       *plist = build_tree_list (NULL_TREE, texpr);
12302       plist = &TREE_CHAIN (*plist);
12303       expr = ffebld_trail (expr);
12304       if (length != NULL_TREE)
12305         {
12306           *ptrail = build_tree_list (NULL_TREE, length);
12307           ptrail = &TREE_CHAIN (*ptrail);
12308         }
12309     }
12310
12311   *plist = trail;
12312
12313   return list;
12314 }
12315
12316 #endif
12317 /* Obtain gcc's LABEL_DECL tree for label.  */
12318
12319 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12320 tree
12321 ffecom_lookup_label (ffelab label)
12322 {
12323   tree glabel;
12324
12325   if (ffelab_hook (label) == NULL_TREE)
12326     {
12327       char labelname[16];
12328
12329       switch (ffelab_type (label))
12330         {
12331         case FFELAB_typeLOOPEND:
12332         case FFELAB_typeNOTLOOP:
12333         case FFELAB_typeENDIF:
12334           sprintf (labelname, "%" ffelabValue_f "u", ffelab_value (label));
12335           glabel = build_decl (LABEL_DECL, get_identifier (labelname),
12336                                void_type_node);
12337           DECL_CONTEXT (glabel) = current_function_decl;
12338           DECL_MODE (glabel) = VOIDmode;
12339           break;
12340
12341         case FFELAB_typeFORMAT:
12342           glabel = build_decl (VAR_DECL,
12343                                ffecom_get_invented_identifier
12344                                ("__g77_format_%d", (int) ffelab_value (label)),
12345                                build_type_variant (build_array_type
12346                                                    (char_type_node,
12347                                                     NULL_TREE),
12348                                                    1, 0));
12349           TREE_CONSTANT (glabel) = 1;
12350           TREE_STATIC (glabel) = 1;
12351           DECL_CONTEXT (glabel) = 0;
12352           DECL_INITIAL (glabel) = NULL;
12353           make_decl_rtl (glabel, NULL, 0);
12354           expand_decl (glabel);
12355
12356           ffecom_save_tree_forever (glabel);
12357
12358           break;
12359
12360         case FFELAB_typeANY:
12361           glabel = error_mark_node;
12362           break;
12363
12364         default:
12365           assert ("bad label type" == NULL);
12366           glabel = NULL;
12367           break;
12368         }
12369       ffelab_set_hook (label, glabel);
12370     }
12371   else
12372     {
12373       glabel = ffelab_hook (label);
12374     }
12375
12376   return glabel;
12377 }
12378
12379 #endif
12380 /* Stabilizes the arguments.  Don't use this if the lhs and rhs come from
12381    a single source specification (as in the fourth argument of MVBITS).
12382    If the type is NULL_TREE, the type of lhs is used to make the type of
12383    the MODIFY_EXPR.  */
12384
12385 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12386 tree
12387 ffecom_modify (tree newtype, tree lhs,
12388                tree rhs)
12389 {
12390   if (lhs == error_mark_node || rhs == error_mark_node)
12391     return error_mark_node;
12392
12393   if (newtype == NULL_TREE)
12394     newtype = TREE_TYPE (lhs);
12395
12396   if (TREE_SIDE_EFFECTS (lhs))
12397     lhs = stabilize_reference (lhs);
12398
12399   return ffecom_2s (MODIFY_EXPR, newtype, lhs, rhs);
12400 }
12401
12402 #endif
12403
12404 /* Register source file name.  */
12405
12406 void
12407 ffecom_file (const char *name)
12408 {
12409 #if FFECOM_GCC_INCLUDE
12410   ffecom_file_ (name);
12411 #endif
12412 }
12413
12414 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
12415
12416    ffestorag st;
12417    ffecom_notify_init_storage(st);
12418
12419    Gets called when all possible units in an aggregate storage area (a LOCAL
12420    with equivalences or a COMMON) have been initialized.  The initialization
12421    info either is in ffestorag_init or, if that is NULL,
12422    ffestorag_accretion:
12423
12424    ffestorag_init may contain an opCONTER or opARRTER.  opCONTER may occur
12425    even for an array if the array is one element in length!
12426
12427    ffestorag_accretion will contain an opACCTER.  It is much like an
12428    opARRTER except it has an ffebit object in it instead of just a size.
12429    The back end can use the info in the ffebit object, if it wants, to
12430    reduce the amount of actual initialization, but in any case it should
12431    kill the ffebit object when done.  Also, set accretion to NULL but
12432    init to a non-NULL value.
12433
12434    After performing initialization, DO NOT set init to NULL, because that'll
12435    tell the front end it is ok for more initialization to happen.  Instead,
12436    set init to an opANY expression or some such thing that you can use to
12437    tell that you've already initialized the object.
12438
12439    27-Oct-91  JCB  1.1
12440       Support two-pass FFE.  */
12441
12442 void
12443 ffecom_notify_init_storage (ffestorag st)
12444 {
12445   ffebld init;                  /* The initialization expression. */
12446 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12447   ffetargetOffset size;         /* The size of the entity. */
12448   ffetargetAlign pad;           /* Its initial padding. */
12449 #endif
12450
12451   if (ffestorag_init (st) == NULL)
12452     {
12453       init = ffestorag_accretion (st);
12454       assert (init != NULL);
12455       ffestorag_set_accretion (st, NULL);
12456       ffestorag_set_accretes (st, 0);
12457
12458 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12459       /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12460       size = ffebld_accter_size (init);
12461       pad = ffebld_accter_pad (init);
12462       ffebit_kill (ffebld_accter_bits (init));
12463       ffebld_set_op (init, FFEBLD_opARRTER);
12464       ffebld_set_arrter (init, ffebld_accter (init));
12465       ffebld_arrter_set_size (init, size);
12466       ffebld_arrter_set_pad (init, size);
12467 #endif
12468
12469 #if FFECOM_TWOPASS
12470       ffestorag_set_init (st, init);
12471 #endif
12472     }
12473 #if FFECOM_ONEPASS
12474   else
12475     init = ffestorag_init (st);
12476 #endif
12477
12478 #if FFECOM_ONEPASS              /* Process the inits, wipe 'em out. */
12479   ffestorag_set_init (st, ffebld_new_any ());
12480
12481   if (ffebld_op (init) == FFEBLD_opANY)
12482     return;                     /* Oh, we already did this! */
12483
12484 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12485   {
12486     ffesymbol s;
12487
12488     if (ffestorag_symbol (st) != NULL)
12489       s = ffestorag_symbol (st);
12490     else
12491       s = ffestorag_typesymbol (st);
12492
12493     fprintf (dmpout, "= initialize_storage \"%s\" ",
12494              (s != NULL) ? ffesymbol_text (s) : "(unnamed)");
12495     ffebld_dump (init);
12496     fputc ('\n', dmpout);
12497   }
12498 #endif
12499
12500 #endif /* if FFECOM_ONEPASS */
12501 }
12502
12503 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12504
12505    ffesymbol s;
12506    ffecom_notify_init_symbol(s);
12507
12508    Gets called when all possible units in a symbol (not placed in COMMON
12509    or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12510    have been initialized.  The initialization info either is in
12511    ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12512
12513    ffesymbol_init may contain an opCONTER or opARRTER.  opCONTER may occur
12514    even for an array if the array is one element in length!
12515
12516    ffesymbol_accretion will contain an opACCTER.  It is much like an
12517    opARRTER except it has an ffebit object in it instead of just a size.
12518    The back end can use the info in the ffebit object, if it wants, to
12519    reduce the amount of actual initialization, but in any case it should
12520    kill the ffebit object when done.  Also, set accretion to NULL but
12521    init to a non-NULL value.
12522
12523    After performing initialization, DO NOT set init to NULL, because that'll
12524    tell the front end it is ok for more initialization to happen.  Instead,
12525    set init to an opANY expression or some such thing that you can use to
12526    tell that you've already initialized the object.
12527
12528    27-Oct-91  JCB  1.1
12529       Support two-pass FFE.  */
12530
12531 void
12532 ffecom_notify_init_symbol (ffesymbol s)
12533 {
12534   ffebld init;                  /* The initialization expression. */
12535 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12536   ffetargetOffset size;         /* The size of the entity. */
12537   ffetargetAlign pad;           /* Its initial padding. */
12538 #endif
12539
12540   if (ffesymbol_storage (s) == NULL)
12541     return;                     /* Do nothing until COMMON/EQUIVALENCE
12542                                    possibilities checked. */
12543
12544   if ((ffesymbol_init (s) == NULL)
12545       && ((init = ffesymbol_accretion (s)) != NULL))
12546     {
12547       ffesymbol_set_accretion (s, NULL);
12548       ffesymbol_set_accretes (s, 0);
12549
12550 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12551       /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12552       size = ffebld_accter_size (init);
12553       pad = ffebld_accter_pad (init);
12554       ffebit_kill (ffebld_accter_bits (init));
12555       ffebld_set_op (init, FFEBLD_opARRTER);
12556       ffebld_set_arrter (init, ffebld_accter (init));
12557       ffebld_arrter_set_size (init, size);
12558       ffebld_arrter_set_pad (init, size);
12559 #endif
12560
12561 #if FFECOM_TWOPASS
12562       ffesymbol_set_init (s, init);
12563 #endif
12564     }
12565 #if FFECOM_ONEPASS
12566   else
12567     init = ffesymbol_init (s);
12568 #endif
12569
12570 #if FFECOM_ONEPASS
12571   ffesymbol_set_init (s, ffebld_new_any ());
12572
12573   if (ffebld_op (init) == FFEBLD_opANY)
12574     return;                     /* Oh, we already did this! */
12575
12576 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12577   fprintf (dmpout, "= initialize_symbol \"%s\" ", ffesymbol_text (s));
12578   ffebld_dump (init);
12579   fputc ('\n', dmpout);
12580 #endif
12581
12582 #endif /* if FFECOM_ONEPASS */
12583 }
12584
12585 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12586
12587    ffesymbol s;
12588    ffecom_notify_primary_entry(s);
12589
12590    Gets called when implicit or explicit PROGRAM statement seen or when
12591    FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12592    global symbol that serves as the entry point.  */
12593
12594 void
12595 ffecom_notify_primary_entry (ffesymbol s)
12596 {
12597   ffecom_primary_entry_ = s;
12598   ffecom_primary_entry_kind_ = ffesymbol_kind (s);
12599
12600   if ((ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
12601       || (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE))
12602     ffecom_primary_entry_is_proc_ = TRUE;
12603   else
12604     ffecom_primary_entry_is_proc_ = FALSE;
12605
12606   if (!ffe_is_silent ())
12607     {
12608       if (ffecom_primary_entry_kind_ == FFEINFO_kindPROGRAM)
12609         fprintf (stderr, "%s:\n", ffesymbol_text (s));
12610       else
12611         fprintf (stderr, "  %s:\n", ffesymbol_text (s));
12612     }
12613
12614 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12615   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
12616     {
12617       ffebld list;
12618       ffebld arg;
12619
12620       for (list = ffesymbol_dummyargs (s);
12621            list != NULL;
12622            list = ffebld_trail (list))
12623         {
12624           arg = ffebld_head (list);
12625           if (ffebld_op (arg) == FFEBLD_opSTAR)
12626             {
12627               ffecom_is_altreturning_ = TRUE;
12628               break;
12629             }
12630         }
12631     }
12632 #endif
12633 }
12634
12635 FILE *
12636 ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c)
12637 {
12638 #if FFECOM_GCC_INCLUDE
12639   return ffecom_open_include_ (name, l, c);
12640 #else
12641   return fopen (name, "r");
12642 #endif
12643 }
12644
12645 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
12646
12647    tree t;
12648    ffebld expr;  // FFE expression.
12649    tree = ffecom_ptr_to_expr(expr);
12650
12651    Like ffecom_expr, but sticks address-of in front of most things.  */
12652
12653 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12654 tree
12655 ffecom_ptr_to_expr (ffebld expr)
12656 {
12657   tree item;
12658   ffeinfoBasictype bt;
12659   ffeinfoKindtype kt;
12660   ffesymbol s;
12661
12662   assert (expr != NULL);
12663
12664   switch (ffebld_op (expr))
12665     {
12666     case FFEBLD_opSYMTER:
12667       s = ffebld_symter (expr);
12668       if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
12669         {
12670           ffecomGfrt ix;
12671
12672           ix = ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr));
12673           assert (ix != FFECOM_gfrt);
12674           if ((item = ffecom_gfrt_[ix]) == NULL_TREE)
12675             {
12676               ffecom_make_gfrt_ (ix);
12677               item = ffecom_gfrt_[ix];
12678             }
12679         }
12680       else
12681         {
12682           item = ffesymbol_hook (s).decl_tree;
12683           if (item == NULL_TREE)
12684             {
12685               s = ffecom_sym_transform_ (s);
12686               item = ffesymbol_hook (s).decl_tree;
12687             }
12688         }
12689       assert (item != NULL);
12690       if (item == error_mark_node)
12691         return item;
12692       if (!ffesymbol_hook (s).addr)
12693         item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12694                          item);
12695       return item;
12696
12697     case FFEBLD_opARRAYREF:
12698       return ffecom_arrayref_ (NULL_TREE, expr, 1);
12699
12700     case FFEBLD_opCONTER:
12701
12702       bt = ffeinfo_basictype (ffebld_info (expr));
12703       kt = ffeinfo_kindtype (ffebld_info (expr));
12704
12705       item = ffecom_constantunion (&ffebld_constant_union
12706                                    (ffebld_conter (expr)), bt, kt,
12707                                    ffecom_tree_type[bt][kt]);
12708       if (item == error_mark_node)
12709         return error_mark_node;
12710       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12711                        item);
12712       return item;
12713
12714     case FFEBLD_opANY:
12715       return error_mark_node;
12716
12717     default:
12718       bt = ffeinfo_basictype (ffebld_info (expr));
12719       kt = ffeinfo_kindtype (ffebld_info (expr));
12720
12721       item = ffecom_expr (expr);
12722       if (item == error_mark_node)
12723         return error_mark_node;
12724
12725       /* The back end currently optimizes a bit too zealously for us, in that
12726          we fail JCB001 if the following block of code is omitted.  It checks
12727          to see if the transformed expression is a symbol or array reference,
12728          and encloses it in a SAVE_EXPR if that is the case.  */
12729
12730       STRIP_NOPS (item);
12731       if ((TREE_CODE (item) == VAR_DECL)
12732           || (TREE_CODE (item) == PARM_DECL)
12733           || (TREE_CODE (item) == RESULT_DECL)
12734           || (TREE_CODE (item) == INDIRECT_REF)
12735           || (TREE_CODE (item) == ARRAY_REF)
12736           || (TREE_CODE (item) == COMPONENT_REF)
12737 #ifdef OFFSET_REF
12738           || (TREE_CODE (item) == OFFSET_REF)
12739 #endif
12740           || (TREE_CODE (item) == BUFFER_REF)
12741           || (TREE_CODE (item) == REALPART_EXPR)
12742           || (TREE_CODE (item) == IMAGPART_EXPR))
12743         {
12744           item = ffecom_save_tree (item);
12745         }
12746
12747       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12748                        item);
12749       return item;
12750     }
12751
12752   assert ("fall-through error" == NULL);
12753   return error_mark_node;
12754 }
12755
12756 #endif
12757 /* Obtain a temp var with given data type.
12758
12759    size is FFETARGET_charactersizeNONE for a non-CHARACTER type
12760    or >= 0 for a CHARACTER type.
12761
12762    elements is -1 for a scalar or > 0 for an array of type.  */
12763
12764 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12765 tree
12766 ffecom_make_tempvar (const char *commentary, tree type,
12767                      ffetargetCharacterSize size, int elements)
12768 {
12769   int yes;
12770   tree t;
12771   static int mynumber;
12772
12773   assert (current_binding_level->prep_state < 2);
12774
12775   if (type == error_mark_node)
12776     return error_mark_node;
12777
12778   yes = suspend_momentary ();
12779
12780   if (size != FFETARGET_charactersizeNONE)
12781     type = build_array_type (type,
12782                              build_range_type (ffecom_f2c_ftnlen_type_node,
12783                                                ffecom_f2c_ftnlen_one_node,
12784                                                build_int_2 (size, 0)));
12785   if (elements != -1)
12786     type = build_array_type (type,
12787                              build_range_type (integer_type_node,
12788                                                integer_zero_node,
12789                                                build_int_2 (elements - 1,
12790                                                             0)));
12791   t = build_decl (VAR_DECL,
12792                   ffecom_get_invented_identifier ("__g77_%s_%d",
12793                                                   commentary,
12794                                                   mynumber++),
12795                   type);
12796
12797   t = start_decl (t, FALSE);
12798   finish_decl (t, NULL_TREE, FALSE);
12799
12800   resume_momentary (yes);
12801
12802   return t;
12803 }
12804 #endif
12805
12806 /* Prepare argument pointer to expression.
12807
12808    Like ffecom_prepare_expr, except for expressions to be evaluated
12809    via ffecom_arg_ptr_to_expr.  */
12810
12811 void
12812 ffecom_prepare_arg_ptr_to_expr (ffebld expr)
12813 {
12814   /* ~~For now, it seems to be the same thing.  */
12815   ffecom_prepare_expr (expr);
12816   return;
12817 }
12818
12819 /* End of preparations.  */
12820
12821 bool
12822 ffecom_prepare_end (void)
12823 {
12824   int prep_state = current_binding_level->prep_state;
12825
12826   assert (prep_state < 2);
12827   current_binding_level->prep_state = 2;
12828
12829   return (prep_state == 1) ? TRUE : FALSE;
12830 }
12831
12832 /* Prepare expression.
12833
12834    This is called before any code is generated for the current block.
12835    It scans the expression, declares any temporaries that might be needed
12836    during evaluation of the expression, and stores those temporaries in
12837    the appropriate "hook" fields of the expression.  `dest', if not NULL,
12838    specifies the destination that ffecom_expr_ will see, in case that
12839    helps avoid generating unused temporaries.
12840
12841    ~~Improve to avoid allocating unused temporaries by taking `dest'
12842    into account vis-a-vis aliasing requirements of complex/character
12843    functions.  */
12844
12845 void
12846 ffecom_prepare_expr_ (ffebld expr, ffebld dest UNUSED)
12847 {
12848   ffeinfoBasictype bt;
12849   ffeinfoKindtype kt;
12850   ffetargetCharacterSize sz;
12851   tree tempvar = NULL_TREE;
12852
12853   assert (current_binding_level->prep_state < 2);
12854
12855   if (! expr)
12856     return;
12857
12858   bt = ffeinfo_basictype (ffebld_info (expr));
12859   kt = ffeinfo_kindtype (ffebld_info (expr));
12860   sz = ffeinfo_size (ffebld_info (expr));
12861
12862   /* Generate whatever temporaries are needed to represent the result
12863      of the expression.  */
12864
12865   if (bt == FFEINFO_basictypeCHARACTER)
12866     {
12867       while (ffebld_op (expr) == FFEBLD_opPAREN)
12868         expr = ffebld_left (expr);
12869     }
12870
12871   switch (ffebld_op (expr))
12872     {
12873     default:
12874       /* Don't make temps for SYMTER, CONTER, etc.  */
12875       if (ffebld_arity (expr) == 0)
12876         break;
12877
12878       switch (bt)
12879         {
12880         case FFEINFO_basictypeCOMPLEX:
12881           if (ffebld_op (expr) == FFEBLD_opFUNCREF)
12882             {
12883               ffesymbol s;
12884
12885               if (ffebld_op (ffebld_left (expr)) != FFEBLD_opSYMTER)
12886                 break;
12887
12888               s = ffebld_symter (ffebld_left (expr));
12889               if (ffesymbol_where (s) == FFEINFO_whereCONSTANT
12890                   || (ffesymbol_where (s) != FFEINFO_whereINTRINSIC
12891                       && ! ffesymbol_is_f2c (s))
12892                   || (ffesymbol_where (s) == FFEINFO_whereINTRINSIC
12893                       && ! ffe_is_f2c_library ()))
12894                 break;
12895             }
12896           else if (ffebld_op (expr) == FFEBLD_opPOWER)
12897             {
12898               /* Requires special treatment.  There's no POW_CC function
12899                  in libg2c, so POW_ZZ is used, which means we always
12900                  need a double-complex temp, not a single-complex.  */
12901               kt = FFEINFO_kindtypeREAL2;
12902             }
12903           else if (ffebld_op (expr) != FFEBLD_opDIVIDE)
12904             /* The other ops don't need temps for complex operands.  */
12905             break;
12906
12907           /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
12908              REAL(C).  See 19990325-0.f, routine `check', for cases.  */
12909           tempvar = ffecom_make_tempvar ("complex",
12910                                          ffecom_tree_type
12911                                          [FFEINFO_basictypeCOMPLEX][kt],
12912                                          FFETARGET_charactersizeNONE,
12913                                          -1);
12914           break;
12915
12916         case FFEINFO_basictypeCHARACTER:
12917           if (ffebld_op (expr) != FFEBLD_opFUNCREF)
12918             break;
12919
12920           if (sz == FFETARGET_charactersizeNONE)
12921             /* ~~Kludge alert!  This should someday be fixed. */
12922             sz = 24;
12923
12924           tempvar = ffecom_make_tempvar ("char", char_type_node, sz, -1);
12925           break;
12926
12927         default:
12928           break;
12929         }
12930       break;
12931
12932 #ifdef HAHA
12933     case FFEBLD_opPOWER:
12934       {
12935         tree rtype, ltype;
12936         tree rtmp, ltmp, result;
12937
12938         ltype = ffecom_type_expr (ffebld_left (expr));
12939         rtype = ffecom_type_expr (ffebld_right (expr));
12940
12941         rtmp = ffecom_make_tempvar (rtype, FFETARGET_charactersizeNONE, -1);
12942         ltmp = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12943         result = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12944
12945         tempvar = make_tree_vec (3);
12946         TREE_VEC_ELT (tempvar, 0) = rtmp;
12947         TREE_VEC_ELT (tempvar, 1) = ltmp;
12948         TREE_VEC_ELT (tempvar, 2) = result;
12949       }
12950       break;
12951 #endif  /* HAHA */
12952
12953     case FFEBLD_opCONCATENATE:
12954       {
12955         /* This gets special handling, because only one set of temps
12956            is needed for a tree of these -- the tree is treated as
12957            a flattened list of concatenations when generating code.  */
12958
12959         ffecomConcatList_ catlist;
12960         tree ltmp, itmp, result;
12961         int count;
12962         int i;
12963
12964         catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
12965         count = ffecom_concat_list_count_ (catlist);
12966
12967         if (count >= 2)
12968           {
12969             ltmp
12970               = ffecom_make_tempvar ("concat_len",
12971                                      ffecom_f2c_ftnlen_type_node,
12972                                      FFETARGET_charactersizeNONE, count);
12973             itmp
12974               = ffecom_make_tempvar ("concat_item",
12975                                      ffecom_f2c_address_type_node,
12976                                      FFETARGET_charactersizeNONE, count);
12977             result
12978               = ffecom_make_tempvar ("concat_res",
12979                                      char_type_node,
12980                                      ffecom_concat_list_maxlen_ (catlist),
12981                                      -1);
12982
12983             tempvar = make_tree_vec (3);
12984             TREE_VEC_ELT (tempvar, 0) = ltmp;
12985             TREE_VEC_ELT (tempvar, 1) = itmp;
12986             TREE_VEC_ELT (tempvar, 2) = result;
12987           }
12988
12989         for (i = 0; i < count; ++i)
12990           ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist,
12991                                                                     i));
12992
12993         ffecom_concat_list_kill_ (catlist);
12994
12995         if (tempvar)
12996           {
12997             ffebld_nonter_set_hook (expr, tempvar);
12998             current_binding_level->prep_state = 1;
12999           }
13000       }
13001       return;
13002
13003     case FFEBLD_opCONVERT:
13004       if (bt == FFEINFO_basictypeCHARACTER
13005           && ((ffebld_size_known (ffebld_left (expr))
13006                == FFETARGET_charactersizeNONE)
13007               || (ffebld_size_known (ffebld_left (expr)) >= sz)))
13008         tempvar = ffecom_make_tempvar ("convert", char_type_node, sz, -1);
13009       break;
13010     }
13011
13012   if (tempvar)
13013     {
13014       ffebld_nonter_set_hook (expr, tempvar);
13015       current_binding_level->prep_state = 1;
13016     }
13017
13018   /* Prepare subexpressions for this expr.  */
13019
13020   switch (ffebld_op (expr))
13021     {
13022     case FFEBLD_opPERCENT_LOC:
13023       ffecom_prepare_ptr_to_expr (ffebld_left (expr));
13024       break;
13025
13026     case FFEBLD_opPERCENT_VAL:
13027     case FFEBLD_opPERCENT_REF:
13028       ffecom_prepare_expr (ffebld_left (expr));
13029       break;
13030
13031     case FFEBLD_opPERCENT_DESCR:
13032       ffecom_prepare_arg_ptr_to_expr (ffebld_left (expr));
13033       break;
13034
13035     case FFEBLD_opITEM:
13036       {
13037         ffebld item;
13038
13039         for (item = expr;
13040              item != NULL;
13041              item = ffebld_trail (item))
13042           if (ffebld_head (item) != NULL)
13043             ffecom_prepare_expr (ffebld_head (item));
13044       }
13045       break;
13046
13047     default:
13048       /* Need to handle character conversion specially.  */
13049       switch (ffebld_arity (expr))
13050         {
13051         case 2:
13052           ffecom_prepare_expr (ffebld_left (expr));
13053           ffecom_prepare_expr (ffebld_right (expr));
13054           break;
13055
13056         case 1:
13057           ffecom_prepare_expr (ffebld_left (expr));
13058           break;
13059
13060         default:
13061           break;
13062         }
13063     }
13064
13065   return;
13066 }
13067
13068 /* Prepare expression for reading and writing.
13069
13070    Like ffecom_prepare_expr, except for expressions to be evaluated
13071    via ffecom_expr_rw.  */
13072
13073 void
13074 ffecom_prepare_expr_rw (tree type, ffebld expr)
13075 {
13076   /* This is all we support for now.  */
13077   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
13078
13079   /* ~~For now, it seems to be the same thing.  */
13080   ffecom_prepare_expr (expr);
13081   return;
13082 }
13083
13084 /* Prepare expression for writing.
13085
13086    Like ffecom_prepare_expr, except for expressions to be evaluated
13087    via ffecom_expr_w.  */
13088
13089 void
13090 ffecom_prepare_expr_w (tree type, ffebld expr)
13091 {
13092   /* This is all we support for now.  */
13093   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
13094
13095   /* ~~For now, it seems to be the same thing.  */
13096   ffecom_prepare_expr (expr);
13097   return;
13098 }
13099
13100 /* Prepare expression for returning.
13101
13102    Like ffecom_prepare_expr, except for expressions to be evaluated
13103    via ffecom_return_expr.  */
13104
13105 void
13106 ffecom_prepare_return_expr (ffebld expr)
13107 {
13108   assert (current_binding_level->prep_state < 2);
13109
13110   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE
13111       && ffecom_is_altreturning_
13112       && expr != NULL)
13113     ffecom_prepare_expr (expr);
13114 }
13115
13116 /* Prepare pointer to expression.
13117
13118    Like ffecom_prepare_expr, except for expressions to be evaluated
13119    via ffecom_ptr_to_expr.  */
13120
13121 void
13122 ffecom_prepare_ptr_to_expr (ffebld expr)
13123 {
13124   /* ~~For now, it seems to be the same thing.  */
13125   ffecom_prepare_expr (expr);
13126   return;
13127 }
13128
13129 /* Transform expression into constant pointer-to-expression tree.
13130
13131    If the expression can be transformed into a pointer-to-expression tree
13132    that is constant, that is done, and the tree returned.  Else NULL_TREE
13133    is returned.
13134
13135    That way, a caller can attempt to provide compile-time initialization
13136    of a variable and, if that fails, *then* choose to start a new block
13137    and resort to using temporaries, as appropriate.  */
13138
13139 tree
13140 ffecom_ptr_to_const_expr (ffebld expr)
13141 {
13142   if (! expr)
13143     return integer_zero_node;
13144
13145   if (ffebld_op (expr) == FFEBLD_opANY)
13146     return error_mark_node;
13147
13148   if (ffebld_arity (expr) == 0
13149       && (ffebld_op (expr) != FFEBLD_opSYMTER
13150           || ffebld_where (expr) == FFEINFO_whereCOMMON
13151           || ffebld_where (expr) == FFEINFO_whereGLOBAL
13152           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
13153     {
13154       tree t;
13155
13156       t = ffecom_ptr_to_expr (expr);
13157       assert (TREE_CONSTANT (t));
13158       return t;
13159     }
13160
13161   return NULL_TREE;
13162 }
13163
13164 /* ffecom_return_expr -- Returns return-value expr given alt return expr
13165
13166    tree rtn;  // NULL_TREE means use expand_null_return()
13167    ffebld expr;  // NULL if no alt return expr to RETURN stmt
13168    rtn = ffecom_return_expr(expr);
13169
13170    Based on the program unit type and other info (like return function
13171    type, return master function type when alternate ENTRY points,
13172    whether subroutine has any alternate RETURN points, etc), returns the
13173    appropriate expression to be returned to the caller, or NULL_TREE
13174    meaning no return value or the caller expects it to be returned somewhere
13175    else (which is handled by other parts of this module).  */
13176
13177 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13178 tree
13179 ffecom_return_expr (ffebld expr)
13180 {
13181   tree rtn;
13182
13183   switch (ffecom_primary_entry_kind_)
13184     {
13185     case FFEINFO_kindPROGRAM:
13186     case FFEINFO_kindBLOCKDATA:
13187       rtn = NULL_TREE;
13188       break;
13189
13190     case FFEINFO_kindSUBROUTINE:
13191       if (!ffecom_is_altreturning_)
13192         rtn = NULL_TREE;        /* No alt returns, never an expr. */
13193       else if (expr == NULL)
13194         rtn = integer_zero_node;
13195       else
13196         rtn = ffecom_expr (expr);
13197       break;
13198
13199     case FFEINFO_kindFUNCTION:
13200       if ((ffecom_multi_retval_ != NULL_TREE)
13201           || (ffesymbol_basictype (ffecom_primary_entry_)
13202               == FFEINFO_basictypeCHARACTER)
13203           || ((ffesymbol_basictype (ffecom_primary_entry_)
13204                == FFEINFO_basictypeCOMPLEX)
13205               && (ffecom_num_entrypoints_ == 0)
13206               && ffesymbol_is_f2c (ffecom_primary_entry_)))
13207         {                       /* Value is returned by direct assignment
13208                                    into (implicit) dummy. */
13209           rtn = NULL_TREE;
13210           break;
13211         }
13212       rtn = ffecom_func_result_;
13213 #if 0
13214       /* Spurious error if RETURN happens before first reference!  So elide
13215          this code.  In particular, for debugging registry, rtn should always
13216          be non-null after all, but TREE_USED won't be set until we encounter
13217          a reference in the code.  Perfectly okay (but weird) code that,
13218          e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
13219          this diagnostic for no reason.  Have people use -O -Wuninitialized
13220          and leave it to the back end to find obviously weird cases.  */
13221
13222       /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
13223          situation; if the return value has never been referenced, it won't
13224          have a tree under 2pass mode. */
13225       if ((rtn == NULL_TREE)
13226           || !TREE_USED (rtn))
13227         {
13228           ffebad_start (FFEBAD_RETURN_VALUE_UNSET);
13229           ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_),
13230                        ffesymbol_where_column (ffecom_primary_entry_));
13231           ffebad_string (ffesymbol_text (ffesymbol_funcresult
13232                                          (ffecom_primary_entry_)));
13233           ffebad_finish ();
13234         }
13235 #endif
13236       break;
13237
13238     default:
13239       assert ("bad unit kind" == NULL);
13240     case FFEINFO_kindANY:
13241       rtn = error_mark_node;
13242       break;
13243     }
13244
13245   return rtn;
13246 }
13247
13248 #endif
13249 /* Do save_expr only if tree is not error_mark_node.  */
13250
13251 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13252 tree
13253 ffecom_save_tree (tree t)
13254 {
13255   return save_expr (t);
13256 }
13257 #endif
13258
13259 /* Start a compound statement (block).  */
13260
13261 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13262 void
13263 ffecom_start_compstmt (void)
13264 {
13265   bison_rule_pushlevel_ ();
13266 }
13267 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
13268
13269 /* Public entry point for front end to access start_decl.  */
13270
13271 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13272 tree
13273 ffecom_start_decl (tree decl, bool is_initialized)
13274 {
13275   DECL_INITIAL (decl) = is_initialized ? error_mark_node : NULL_TREE;
13276   return start_decl (decl, FALSE);
13277 }
13278
13279 #endif
13280 /* ffecom_sym_commit -- Symbol's state being committed to reality
13281
13282    ffesymbol s;
13283    ffecom_sym_commit(s);
13284
13285    Does whatever the backend needs when a symbol is committed after having
13286    been backtrackable for a period of time.  */
13287
13288 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13289 void
13290 ffecom_sym_commit (ffesymbol s UNUSED)
13291 {
13292   assert (!ffesymbol_retractable ());
13293 }
13294
13295 #endif
13296 /* ffecom_sym_end_transition -- Perform end transition on all symbols
13297
13298    ffecom_sym_end_transition();
13299
13300    Does backend-specific stuff and also calls ffest_sym_end_transition
13301    to do the necessary FFE stuff.
13302
13303    Backtracking is never enabled when this fn is called, so don't worry
13304    about it.  */
13305
13306 ffesymbol
13307 ffecom_sym_end_transition (ffesymbol s)
13308 {
13309   ffestorag st;
13310
13311   assert (!ffesymbol_retractable ());
13312
13313   s = ffest_sym_end_transition (s);
13314
13315 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13316   if ((ffesymbol_kind (s) == FFEINFO_kindBLOCKDATA)
13317       && (ffesymbol_where (s) == FFEINFO_whereGLOBAL))
13318     {
13319       ffecom_list_blockdata_
13320         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
13321                                               FFEINTRIN_specNONE,
13322                                               FFEINTRIN_impNONE),
13323                            ffecom_list_blockdata_);
13324     }
13325 #endif
13326
13327   /* This is where we finally notice that a symbol has partial initialization
13328      and finalize it. */
13329
13330   if (ffesymbol_accretion (s) != NULL)
13331     {
13332       assert (ffesymbol_init (s) == NULL);
13333       ffecom_notify_init_symbol (s);
13334     }
13335   else if (((st = ffesymbol_storage (s)) != NULL)
13336            && ((st = ffestorag_parent (st)) != NULL)
13337            && (ffestorag_accretion (st) != NULL))
13338     {
13339       assert (ffestorag_init (st) == NULL);
13340       ffecom_notify_init_storage (st);
13341     }
13342
13343 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13344   if ((ffesymbol_kind (s) == FFEINFO_kindCOMMON)
13345       && (ffesymbol_where (s) == FFEINFO_whereLOCAL)
13346       && (ffesymbol_storage (s) != NULL))
13347     {
13348       ffecom_list_common_
13349         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
13350                                               FFEINTRIN_specNONE,
13351                                               FFEINTRIN_impNONE),
13352                            ffecom_list_common_);
13353     }
13354 #endif
13355
13356   return s;
13357 }
13358
13359 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
13360
13361    ffecom_sym_exec_transition();
13362
13363    Does backend-specific stuff and also calls ffest_sym_exec_transition
13364    to do the necessary FFE stuff.
13365
13366    See the long-winded description in ffecom_sym_learned for info
13367    on handling the situation where backtracking is inhibited.  */
13368
13369 ffesymbol
13370 ffecom_sym_exec_transition (ffesymbol s)
13371 {
13372   s = ffest_sym_exec_transition (s);
13373
13374   return s;
13375 }
13376
13377 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
13378
13379    ffesymbol s;
13380    s = ffecom_sym_learned(s);
13381
13382    Called when a new symbol is seen after the exec transition or when more
13383    info (perhaps) is gained for an UNCERTAIN symbol.  The symbol state when
13384    it arrives here is that all its latest info is updated already, so its
13385    state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
13386    field filled in if its gone through here or exec_transition first, and
13387    so on.
13388
13389    The backend probably wants to check ffesymbol_retractable() to see if
13390    backtracking is in effect.  If so, the FFE's changes to the symbol may
13391    be retracted (undone) or committed (ratified), at which time the
13392    appropriate ffecom_sym_retract or _commit function will be called
13393    for that function.
13394
13395    If the backend has its own backtracking mechanism, great, use it so that
13396    committal is a simple operation.  Though it doesn't make much difference,
13397    I suppose: the reason for tentative symbol evolution in the FFE is to
13398    enable error detection in weird incorrect statements early and to disable
13399    incorrect error detection on a correct statement.  The backend is not
13400    likely to introduce any information that'll get involved in these
13401    considerations, so it is probably just fine that the implementation
13402    model for this fn and for _exec_transition is to not do anything
13403    (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
13404    and instead wait until ffecom_sym_commit is called (which it never
13405    will be as long as we're using ambiguity-detecting statement analysis in
13406    the FFE, which we are initially to shake out the code, but don't depend
13407    on this), otherwise go ahead and do whatever is needed.
13408
13409    In essence, then, when this fn and _exec_transition get called while
13410    backtracking is enabled, a general mechanism would be to flag which (or
13411    both) of these were called (and in what order? neat question as to what
13412    might happen that I'm too lame to think through right now) and then when
13413    _commit is called reproduce the original calling sequence, if any, for
13414    the two fns (at which point backtracking will, of course, be disabled).  */
13415
13416 ffesymbol
13417 ffecom_sym_learned (ffesymbol s)
13418 {
13419   ffestorag_exec_layout (s);
13420
13421   return s;
13422 }
13423
13424 /* ffecom_sym_retract -- Symbol's state being retracted from reality
13425
13426    ffesymbol s;
13427    ffecom_sym_retract(s);
13428
13429    Does whatever the backend needs when a symbol is retracted after having
13430    been backtrackable for a period of time.  */
13431
13432 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13433 void
13434 ffecom_sym_retract (ffesymbol s UNUSED)
13435 {
13436   assert (!ffesymbol_retractable ());
13437
13438 #if 0                           /* GCC doesn't commit any backtrackable sins,
13439                                    so nothing needed here. */
13440   switch (ffesymbol_hook (s).state)
13441     {
13442     case 0:                     /* nothing happened yet. */
13443       break;
13444
13445     case 1:                     /* exec transition happened. */
13446       break;
13447
13448     case 2:                     /* learned happened. */
13449       break;
13450
13451     case 3:                     /* learned then exec. */
13452       break;
13453
13454     case 4:                     /* exec then learned. */
13455       break;
13456
13457     default:
13458       assert ("bad hook state" == NULL);
13459       break;
13460     }
13461 #endif
13462 }
13463
13464 #endif
13465 /* Create temporary gcc label.  */
13466
13467 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13468 tree
13469 ffecom_temp_label ()
13470 {
13471   tree glabel;
13472   static int mynumber = 0;
13473
13474   glabel = build_decl (LABEL_DECL,
13475                        ffecom_get_invented_identifier ("__g77_label_%d",
13476                                                        mynumber++),
13477                        void_type_node);
13478   DECL_CONTEXT (glabel) = current_function_decl;
13479   DECL_MODE (glabel) = VOIDmode;
13480
13481   return glabel;
13482 }
13483
13484 #endif
13485 /* Return an expression that is usable as an arg in a conditional context
13486    (IF, DO WHILE, .NOT., and so on).
13487
13488    Use the one provided for the back end as of >2.6.0.  */
13489
13490 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13491 tree
13492 ffecom_truth_value (tree expr)
13493 {
13494   return truthvalue_conversion (expr);
13495 }
13496
13497 #endif
13498 /* Return the inversion of a truth value (the inversion of what
13499    ffecom_truth_value builds).
13500
13501    Apparently invert_truthvalue, which is properly in the back end, is
13502    enough for now, so just use it.  */
13503
13504 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13505 tree
13506 ffecom_truth_value_invert (tree expr)
13507 {
13508   return invert_truthvalue (ffecom_truth_value (expr));
13509 }
13510
13511 #endif
13512
13513 /* Return the tree that is the type of the expression, as would be
13514    returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
13515    transforming the expression, generating temporaries, etc.  */
13516
13517 tree
13518 ffecom_type_expr (ffebld expr)
13519 {
13520   ffeinfoBasictype bt;
13521   ffeinfoKindtype kt;
13522   tree tree_type;
13523
13524   assert (expr != NULL);
13525
13526   bt = ffeinfo_basictype (ffebld_info (expr));
13527   kt = ffeinfo_kindtype (ffebld_info (expr));
13528   tree_type = ffecom_tree_type[bt][kt];
13529
13530   switch (ffebld_op (expr))
13531     {
13532     case FFEBLD_opCONTER:
13533     case FFEBLD_opSYMTER:
13534     case FFEBLD_opARRAYREF:
13535     case FFEBLD_opUPLUS:
13536     case FFEBLD_opPAREN:
13537     case FFEBLD_opUMINUS:
13538     case FFEBLD_opADD:
13539     case FFEBLD_opSUBTRACT:
13540     case FFEBLD_opMULTIPLY:
13541     case FFEBLD_opDIVIDE:
13542     case FFEBLD_opPOWER:
13543     case FFEBLD_opNOT:
13544     case FFEBLD_opFUNCREF:
13545     case FFEBLD_opSUBRREF:
13546     case FFEBLD_opAND:
13547     case FFEBLD_opOR:
13548     case FFEBLD_opXOR:
13549     case FFEBLD_opNEQV:
13550     case FFEBLD_opEQV:
13551     case FFEBLD_opCONVERT:
13552     case FFEBLD_opLT:
13553     case FFEBLD_opLE:
13554     case FFEBLD_opEQ:
13555     case FFEBLD_opNE:
13556     case FFEBLD_opGT:
13557     case FFEBLD_opGE:
13558     case FFEBLD_opPERCENT_LOC:
13559       return tree_type;
13560
13561     case FFEBLD_opACCTER:
13562     case FFEBLD_opARRTER:
13563     case FFEBLD_opITEM:
13564     case FFEBLD_opSTAR:
13565     case FFEBLD_opBOUNDS:
13566     case FFEBLD_opREPEAT:
13567     case FFEBLD_opLABTER:
13568     case FFEBLD_opLABTOK:
13569     case FFEBLD_opIMPDO:
13570     case FFEBLD_opCONCATENATE:
13571     case FFEBLD_opSUBSTR:
13572     default:
13573       assert ("bad op for ffecom_type_expr" == NULL);
13574       /* Fall through. */
13575     case FFEBLD_opANY:
13576       return error_mark_node;
13577     }
13578 }
13579
13580 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13581
13582    If the PARM_DECL already exists, return it, else create it.  It's an
13583    integer_type_node argument for the master function that implements a
13584    subroutine or function with more than one entrypoint and is bound at
13585    run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13586    first ENTRY statement, and so on).  */
13587
13588 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13589 tree
13590 ffecom_which_entrypoint_decl ()
13591 {
13592   assert (ffecom_which_entrypoint_decl_ != NULL_TREE);
13593
13594   return ffecom_which_entrypoint_decl_;
13595 }
13596
13597 #endif
13598 \f
13599 /* The following sections consists of private and public functions
13600    that have the same names and perform roughly the same functions
13601    as counterparts in the C front end.  Changes in the C front end
13602    might affect how things should be done here.  Only functions
13603    needed by the back end should be public here; the rest should
13604    be private (static in the C sense).  Functions needed by other
13605    g77 front-end modules should be accessed by them via public
13606    ffecom_* names, which should themselves call private versions
13607    in this section so the private versions are easy to recognize
13608    when upgrading to a new gcc and finding interesting changes
13609    in the front end.
13610
13611    Functions named after rule "foo:" in c-parse.y are named
13612    "bison_rule_foo_" so they are easy to find.  */
13613
13614 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13615
13616 static void
13617 bison_rule_pushlevel_ ()
13618 {
13619   emit_line_note (input_filename, lineno);
13620   pushlevel (0);
13621   clear_last_expr ();
13622   push_momentary ();
13623   expand_start_bindings (0);
13624 }
13625
13626 static tree
13627 bison_rule_compstmt_ ()
13628 {
13629   tree t;
13630   int keep = kept_level_p ();
13631
13632   /* Make the temps go away.  */
13633   if (! keep)
13634     current_binding_level->names = NULL_TREE;
13635
13636   emit_line_note (input_filename, lineno);
13637   expand_end_bindings (getdecls (), keep, 0);
13638   t = poplevel (keep, 1, 0);
13639   pop_momentary ();
13640
13641   return t;
13642 }
13643
13644 /* Return a definition for a builtin function named NAME and whose data type
13645    is TYPE.  TYPE should be a function type with argument types.
13646    FUNCTION_CODE tells later passes how to compile calls to this function.
13647    See tree.h for its possible values.
13648
13649    If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13650    the name to be called if we can't opencode the function.  */
13651
13652 tree
13653 builtin_function (const char *name, tree type, int function_code,
13654                   enum built_in_class class,
13655                   const char *library_name)
13656 {
13657   tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
13658   DECL_EXTERNAL (decl) = 1;
13659   TREE_PUBLIC (decl) = 1;
13660   if (library_name)
13661     DECL_ASSEMBLER_NAME (decl) = get_identifier (library_name);
13662   make_decl_rtl (decl, NULL_PTR, 1);
13663   pushdecl (decl);
13664   DECL_BUILT_IN_CLASS (decl) = class;
13665   DECL_FUNCTION_CODE (decl) = function_code;
13666
13667   return decl;
13668 }
13669
13670 /* Handle when a new declaration NEWDECL
13671    has the same name as an old one OLDDECL
13672    in the same binding contour.
13673    Prints an error message if appropriate.
13674
13675    If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13676    Otherwise, return 0.  */
13677
13678 static int
13679 duplicate_decls (tree newdecl, tree olddecl)
13680 {
13681   int types_match = 1;
13682   int new_is_definition = (TREE_CODE (newdecl) == FUNCTION_DECL
13683                            && DECL_INITIAL (newdecl) != 0);
13684   tree oldtype = TREE_TYPE (olddecl);
13685   tree newtype = TREE_TYPE (newdecl);
13686
13687   if (olddecl == newdecl)
13688     return 1;
13689
13690   if (TREE_CODE (newtype) == ERROR_MARK
13691       || TREE_CODE (oldtype) == ERROR_MARK)
13692     types_match = 0;
13693
13694   /* New decl is completely inconsistent with the old one =>
13695      tell caller to replace the old one.
13696      This is always an error except in the case of shadowing a builtin.  */
13697   if (TREE_CODE (olddecl) != TREE_CODE (newdecl))
13698     return 0;
13699
13700   /* For real parm decl following a forward decl,
13701      return 1 so old decl will be reused.  */
13702   if (types_match && TREE_CODE (newdecl) == PARM_DECL
13703       && TREE_ASM_WRITTEN (olddecl) && ! TREE_ASM_WRITTEN (newdecl))
13704     return 1;
13705
13706   /* The new declaration is the same kind of object as the old one.
13707      The declarations may partially match.  Print warnings if they don't
13708      match enough.  Ultimately, copy most of the information from the new
13709      decl to the old one, and keep using the old one.  */
13710
13711   if (TREE_CODE (olddecl) == FUNCTION_DECL
13712       && DECL_BUILT_IN (olddecl))
13713     {
13714       /* A function declaration for a built-in function.  */
13715       if (!TREE_PUBLIC (newdecl))
13716         return 0;
13717       else if (!types_match)
13718         {
13719           /* Accept the return type of the new declaration if same modes.  */
13720           tree oldreturntype = TREE_TYPE (TREE_TYPE (olddecl));
13721           tree newreturntype = TREE_TYPE (TREE_TYPE (newdecl));
13722
13723           if (TYPE_MODE (oldreturntype) == TYPE_MODE (newreturntype))
13724             {
13725               /* Function types may be shared, so we can't just modify
13726                  the return type of olddecl's function type.  */
13727               tree newtype
13728                 = build_function_type (newreturntype,
13729                                        TYPE_ARG_TYPES (TREE_TYPE (olddecl)));
13730
13731               types_match = 1;
13732               if (types_match)
13733                 TREE_TYPE (olddecl) = newtype;
13734             }
13735         }
13736       if (!types_match)
13737         return 0;
13738     }
13739   else if (TREE_CODE (olddecl) == FUNCTION_DECL
13740            && DECL_SOURCE_LINE (olddecl) == 0)
13741     {
13742       /* A function declaration for a predeclared function
13743          that isn't actually built in.  */
13744       if (!TREE_PUBLIC (newdecl))
13745         return 0;
13746       else if (!types_match)
13747         {
13748           /* If the types don't match, preserve volatility indication.
13749              Later on, we will discard everything else about the
13750              default declaration.  */
13751           TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl);
13752         }
13753     }
13754
13755   /* Copy all the DECL_... slots specified in the new decl
13756      except for any that we copy here from the old type.
13757
13758      Past this point, we don't change OLDTYPE and NEWTYPE
13759      even if we change the types of NEWDECL and OLDDECL.  */
13760
13761   if (types_match)
13762     {
13763       /* Merge the data types specified in the two decls.  */
13764       if (TREE_CODE (newdecl) != FUNCTION_DECL || !DECL_BUILT_IN (olddecl))
13765         TREE_TYPE (newdecl)
13766           = TREE_TYPE (olddecl)
13767             = TREE_TYPE (newdecl);
13768
13769       /* Lay the type out, unless already done.  */
13770       if (oldtype != TREE_TYPE (newdecl))
13771         {
13772           if (TREE_TYPE (newdecl) != error_mark_node)
13773             layout_type (TREE_TYPE (newdecl));
13774           if (TREE_CODE (newdecl) != FUNCTION_DECL
13775               && TREE_CODE (newdecl) != TYPE_DECL
13776               && TREE_CODE (newdecl) != CONST_DECL)
13777             layout_decl (newdecl, 0);
13778         }
13779       else
13780         {
13781           /* Since the type is OLDDECL's, make OLDDECL's size go with.  */
13782           DECL_SIZE (newdecl) = DECL_SIZE (olddecl);
13783           DECL_SIZE_UNIT (newdecl) = DECL_SIZE_UNIT (olddecl);
13784           if (TREE_CODE (olddecl) != FUNCTION_DECL)
13785             if (DECL_ALIGN (olddecl) > DECL_ALIGN (newdecl))
13786               DECL_ALIGN (newdecl) = DECL_ALIGN (olddecl);
13787         }
13788
13789       /* Keep the old rtl since we can safely use it.  */
13790       DECL_RTL (newdecl) = DECL_RTL (olddecl);
13791
13792       /* Merge the type qualifiers.  */
13793       if (DECL_BUILT_IN_NONANSI (olddecl) && TREE_THIS_VOLATILE (olddecl)
13794           && !TREE_THIS_VOLATILE (newdecl))
13795         TREE_THIS_VOLATILE (olddecl) = 0;
13796       if (TREE_READONLY (newdecl))
13797         TREE_READONLY (olddecl) = 1;
13798       if (TREE_THIS_VOLATILE (newdecl))
13799         {
13800           TREE_THIS_VOLATILE (olddecl) = 1;
13801           if (TREE_CODE (newdecl) == VAR_DECL)
13802             make_var_volatile (newdecl);
13803         }
13804
13805       /* Keep source location of definition rather than declaration.
13806          Likewise, keep decl at outer scope.  */
13807       if ((DECL_INITIAL (newdecl) == 0 && DECL_INITIAL (olddecl) != 0)
13808           || (DECL_CONTEXT (newdecl) != 0 && DECL_CONTEXT (olddecl) == 0))
13809         {
13810           DECL_SOURCE_LINE (newdecl) = DECL_SOURCE_LINE (olddecl);
13811           DECL_SOURCE_FILE (newdecl) = DECL_SOURCE_FILE (olddecl);
13812
13813           if (DECL_CONTEXT (olddecl) == 0
13814               && TREE_CODE (newdecl) != FUNCTION_DECL)
13815             DECL_CONTEXT (newdecl) = 0;
13816         }
13817
13818       /* Merge the unused-warning information.  */
13819       if (DECL_IN_SYSTEM_HEADER (olddecl))
13820         DECL_IN_SYSTEM_HEADER (newdecl) = 1;
13821       else if (DECL_IN_SYSTEM_HEADER (newdecl))
13822         DECL_IN_SYSTEM_HEADER (olddecl) = 1;
13823
13824       /* Merge the initialization information.  */
13825       if (DECL_INITIAL (newdecl) == 0)
13826         DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13827
13828       /* Merge the section attribute.
13829          We want to issue an error if the sections conflict but that must be
13830          done later in decl_attributes since we are called before attributes
13831          are assigned.  */
13832       if (DECL_SECTION_NAME (newdecl) == NULL_TREE)
13833         DECL_SECTION_NAME (newdecl) = DECL_SECTION_NAME (olddecl);
13834
13835 #if BUILT_FOR_270
13836       if (TREE_CODE (newdecl) == FUNCTION_DECL)
13837         {
13838           DECL_STATIC_CONSTRUCTOR(newdecl) |= DECL_STATIC_CONSTRUCTOR(olddecl);
13839           DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl);
13840         }
13841 #endif
13842     }
13843   /* If cannot merge, then use the new type and qualifiers,
13844      and don't preserve the old rtl.  */
13845   else
13846     {
13847       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13848       TREE_READONLY (olddecl) = TREE_READONLY (newdecl);
13849       TREE_THIS_VOLATILE (olddecl) = TREE_THIS_VOLATILE (newdecl);
13850       TREE_SIDE_EFFECTS (olddecl) = TREE_SIDE_EFFECTS (newdecl);
13851     }
13852
13853   /* Merge the storage class information.  */
13854   /* For functions, static overrides non-static.  */
13855   if (TREE_CODE (newdecl) == FUNCTION_DECL)
13856     {
13857       TREE_PUBLIC (newdecl) &= TREE_PUBLIC (olddecl);
13858       /* This is since we don't automatically
13859          copy the attributes of NEWDECL into OLDDECL.  */
13860       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13861       /* If this clears `static', clear it in the identifier too.  */
13862       if (! TREE_PUBLIC (olddecl))
13863         TREE_PUBLIC (DECL_NAME (olddecl)) = 0;
13864     }
13865   if (DECL_EXTERNAL (newdecl))
13866     {
13867       TREE_STATIC (newdecl) = TREE_STATIC (olddecl);
13868       DECL_EXTERNAL (newdecl) = DECL_EXTERNAL (olddecl);
13869       /* An extern decl does not override previous storage class.  */
13870       TREE_PUBLIC (newdecl) = TREE_PUBLIC (olddecl);
13871     }
13872   else
13873     {
13874       TREE_STATIC (olddecl) = TREE_STATIC (newdecl);
13875       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13876     }
13877
13878   /* If either decl says `inline', this fn is inline,
13879      unless its definition was passed already.  */
13880   if (DECL_INLINE (newdecl) && DECL_INITIAL (olddecl) == 0)
13881     DECL_INLINE (olddecl) = 1;
13882   DECL_INLINE (newdecl) = DECL_INLINE (olddecl);
13883
13884   /* Get rid of any built-in function if new arg types don't match it
13885      or if we have a function definition.  */
13886   if (TREE_CODE (newdecl) == FUNCTION_DECL
13887       && DECL_BUILT_IN (olddecl)
13888       && (!types_match || new_is_definition))
13889     {
13890       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13891       DECL_BUILT_IN_CLASS (olddecl) = NOT_BUILT_IN;
13892     }
13893
13894   /* If redeclaring a builtin function, and not a definition,
13895      it stays built in.
13896      Also preserve various other info from the definition.  */
13897   if (TREE_CODE (newdecl) == FUNCTION_DECL && !new_is_definition)
13898     {
13899       if (DECL_BUILT_IN (olddecl))
13900         {
13901           DECL_BUILT_IN_CLASS (newdecl) = DECL_BUILT_IN_CLASS (olddecl);
13902           DECL_FUNCTION_CODE (newdecl) = DECL_FUNCTION_CODE (olddecl);
13903         }
13904       else
13905         DECL_FRAME_SIZE (newdecl) = DECL_FRAME_SIZE (olddecl);
13906
13907       DECL_RESULT (newdecl) = DECL_RESULT (olddecl);
13908       DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13909       DECL_SAVED_INSNS (newdecl) = DECL_SAVED_INSNS (olddecl);
13910       DECL_ARGUMENTS (newdecl) = DECL_ARGUMENTS (olddecl);
13911     }
13912
13913   /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13914      But preserve olddecl's DECL_UID.  */
13915   {
13916     register unsigned olddecl_uid = DECL_UID (olddecl);
13917
13918     memcpy ((char *) olddecl + sizeof (struct tree_common),
13919             (char *) newdecl + sizeof (struct tree_common),
13920             sizeof (struct tree_decl) - sizeof (struct tree_common));
13921     DECL_UID (olddecl) = olddecl_uid;
13922   }
13923
13924   return 1;
13925 }
13926
13927 /* Finish processing of a declaration;
13928    install its initial value.
13929    If the length of an array type is not known before,
13930    it must be determined now, from the initial value, or it is an error.  */
13931
13932 static void
13933 finish_decl (tree decl, tree init, bool is_top_level)
13934 {
13935   register tree type = TREE_TYPE (decl);
13936   int was_incomplete = (DECL_SIZE (decl) == 0);
13937   int temporary = allocation_temporary_p ();
13938   bool at_top_level = (current_binding_level == global_binding_level);
13939   bool top_level = is_top_level || at_top_level;
13940
13941   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13942      level anyway.  */
13943   assert (!is_top_level || !at_top_level);
13944
13945   if (TREE_CODE (decl) == PARM_DECL)
13946     assert (init == NULL_TREE);
13947   /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
13948      overlaps DECL_ARG_TYPE.  */
13949   else if (init == NULL_TREE)
13950     assert (DECL_INITIAL (decl) == NULL_TREE);
13951   else
13952     assert (DECL_INITIAL (decl) == error_mark_node);
13953
13954   if (init != NULL_TREE)
13955     {
13956       if (TREE_CODE (decl) != TYPE_DECL)
13957         DECL_INITIAL (decl) = init;
13958       else
13959         {
13960           /* typedef foo = bar; store the type of bar as the type of foo.  */
13961           TREE_TYPE (decl) = TREE_TYPE (init);
13962           DECL_INITIAL (decl) = init = 0;
13963         }
13964     }
13965
13966   /* Pop back to the obstack that is current for this binding level. This is
13967      because MAXINDEX, rtl, etc. to be made below must go in the permanent
13968      obstack.  But don't discard the temporary data yet.  */
13969   pop_obstacks ();
13970
13971   /* Deduce size of array from initialization, if not already known */
13972
13973   if (TREE_CODE (type) == ARRAY_TYPE
13974       && TYPE_DOMAIN (type) == 0
13975       && TREE_CODE (decl) != TYPE_DECL)
13976     {
13977       assert (top_level);
13978       assert (was_incomplete);
13979
13980       layout_decl (decl, 0);
13981     }
13982
13983   if (TREE_CODE (decl) == VAR_DECL)
13984     {
13985       if (DECL_SIZE (decl) == NULL_TREE
13986           && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
13987         layout_decl (decl, 0);
13988
13989       if (DECL_SIZE (decl) == NULL_TREE
13990           && (TREE_STATIC (decl)
13991               ?
13992       /* A static variable with an incomplete type is an error if it is
13993          initialized. Also if it is not file scope. Otherwise, let it
13994          through, but if it is not `extern' then it may cause an error
13995          message later.  */
13996               (DECL_INITIAL (decl) != 0 || DECL_CONTEXT (decl) != 0)
13997               :
13998       /* An automatic variable with an incomplete type is an error.  */
13999               !DECL_EXTERNAL (decl)))
14000         {
14001           assert ("storage size not known" == NULL);
14002           abort ();
14003         }
14004
14005       if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
14006           && (DECL_SIZE (decl) != 0)
14007           && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
14008         {
14009           assert ("storage size not constant" == NULL);
14010           abort ();
14011         }
14012     }
14013
14014   /* Output the assembler code and/or RTL code for variables and functions,
14015      unless the type is an undefined structure or union. If not, it will get
14016      done when the type is completed.  */
14017
14018   if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL)
14019     {
14020       rest_of_decl_compilation (decl, NULL,
14021                                 DECL_CONTEXT (decl) == 0,
14022                                 0);
14023
14024       if (DECL_CONTEXT (decl) != 0)
14025         {
14026           /* Recompute the RTL of a local array now if it used to be an
14027              incomplete type.  */
14028           if (was_incomplete
14029               && !TREE_STATIC (decl) && !DECL_EXTERNAL (decl))
14030             {
14031               /* If we used it already as memory, it must stay in memory.  */
14032               TREE_ADDRESSABLE (decl) = TREE_USED (decl);
14033               /* If it's still incomplete now, no init will save it.  */
14034               if (DECL_SIZE (decl) == 0)
14035                 DECL_INITIAL (decl) = 0;
14036               expand_decl (decl);
14037             }
14038           /* Compute and store the initial value.  */
14039           if (TREE_CODE (decl) != FUNCTION_DECL)
14040             expand_decl_init (decl);
14041         }
14042     }
14043   else if (TREE_CODE (decl) == TYPE_DECL)
14044     {
14045       rest_of_decl_compilation (decl, NULL_PTR,
14046                                 DECL_CONTEXT (decl) == 0,
14047                                 0);
14048     }
14049
14050   if (!(TREE_CODE (decl) == FUNCTION_DECL && DECL_INLINE (decl))
14051       && temporary
14052   /* DECL_INITIAL is not defined in PARM_DECLs, since it shares space with
14053      DECL_ARG_TYPE.  */
14054       && TREE_CODE (decl) != PARM_DECL)
14055     {
14056       /* We need to remember that this array HAD an initialization, but
14057          discard the actual temporary nodes, since we can't have a permanent
14058          node keep pointing to them.  */
14059       /* We make an exception for inline functions, since it's normal for a
14060          local extern redeclaration of an inline function to have a copy of
14061          the top-level decl's DECL_INLINE.  */
14062       if ((DECL_INITIAL (decl) != 0)
14063           && (DECL_INITIAL (decl) != error_mark_node))
14064         {
14065           /* If this is a const variable, then preserve the
14066              initializer instead of discarding it so that we can optimize
14067              references to it.  */
14068           /* This test used to include TREE_STATIC, but this won't be set
14069              for function level initializers.  */
14070           if (TREE_READONLY (decl))
14071             {
14072               preserve_initializer ();
14073
14074               /* The initializer and DECL must have the same (or equivalent
14075                  types), but if the initializer is a STRING_CST, its type
14076                  might not be on the right obstack, so copy the type
14077                  of DECL.  */
14078               TREE_TYPE (DECL_INITIAL (decl)) = type;
14079             }
14080           else
14081             DECL_INITIAL (decl) = error_mark_node;
14082         }
14083     }
14084
14085   /* If we have gone back from temporary to permanent allocation, actually
14086      free the temporary space that we no longer need.  */
14087   if (temporary && !allocation_temporary_p ())
14088     permanent_allocation (0);
14089
14090   /* At the end of a declaration, throw away any variable type sizes of types
14091      defined inside that declaration.  There is no use computing them in the
14092      following function definition.  */
14093   if (current_binding_level == global_binding_level)
14094     get_pending_sizes ();
14095 }
14096
14097 /* Finish up a function declaration and compile that function
14098    all the way to assembler language output.  The free the storage
14099    for the function definition.
14100
14101    This is called after parsing the body of the function definition.
14102
14103    NESTED is nonzero if the function being finished is nested in another.  */
14104
14105 static void
14106 finish_function (int nested)
14107 {
14108   register tree fndecl = current_function_decl;
14109
14110   assert (fndecl != NULL_TREE);
14111   if (TREE_CODE (fndecl) != ERROR_MARK)
14112     {
14113       if (nested)
14114         assert (DECL_CONTEXT (fndecl) != NULL_TREE);
14115       else
14116         assert (DECL_CONTEXT (fndecl) == NULL_TREE);
14117     }
14118
14119 /*  TREE_READONLY (fndecl) = 1;
14120     This caused &foo to be of type ptr-to-const-function
14121     which then got a warning when stored in a ptr-to-function variable.  */
14122
14123   poplevel (1, 0, 1);
14124
14125   if (TREE_CODE (fndecl) != ERROR_MARK)
14126     {
14127       BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
14128
14129       /* Must mark the RESULT_DECL as being in this function.  */
14130
14131       DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
14132
14133       /* Obey `register' declarations if `setjmp' is called in this fn.  */
14134       /* Generate rtl for function exit.  */
14135       expand_function_end (input_filename, lineno, 0);
14136
14137       /* So we can tell if jump_optimize sets it to 1.  */
14138       can_reach_end = 0;
14139
14140       /* If this is a nested function, protect the local variables in the stack
14141          above us from being collected while we're compiling this function.  */
14142       if (ggc_p && nested)
14143         ggc_push_context ();
14144
14145       /* Run the optimizers and output the assembler code for this function.  */
14146       rest_of_compilation (fndecl);
14147
14148       /* Undo the GC context switch.  */
14149       if (ggc_p && nested)
14150         ggc_pop_context ();
14151     }
14152
14153   /* Free all the tree nodes making up this function.  */
14154   /* Switch back to allocating nodes permanently until we start another
14155      function.  */
14156   if (!nested)
14157     permanent_allocation (1);
14158
14159   if (TREE_CODE (fndecl) != ERROR_MARK
14160       && !nested
14161       && DECL_SAVED_INSNS (fndecl) == 0)
14162     {
14163       /* Stop pointing to the local nodes about to be freed.  */
14164       /* But DECL_INITIAL must remain nonzero so we know this was an actual
14165          function definition.  */
14166       /* For a nested function, this is done in pop_f_function_context.  */
14167       /* If rest_of_compilation set this to 0, leave it 0.  */
14168       if (DECL_INITIAL (fndecl) != 0)
14169         DECL_INITIAL (fndecl) = error_mark_node;
14170       DECL_ARGUMENTS (fndecl) = 0;
14171     }
14172
14173   if (!nested)
14174     {
14175       /* Let the error reporting routines know that we're outside a function.
14176          For a nested function, this value is used in pop_c_function_context
14177          and then reset via pop_function_context.  */
14178       ffecom_outer_function_decl_ = current_function_decl = NULL;
14179     }
14180 }
14181
14182 /* Plug-in replacement for identifying the name of a decl and, for a
14183    function, what we call it in diagnostics.  For now, "program unit"
14184    should suffice, since it's a bit of a hassle to figure out which
14185    of several kinds of things it is.  Note that it could conceivably
14186    be a statement function, which probably isn't really a program unit
14187    per se, but if that comes up, it should be easy to check (being a
14188    nested function and all).  */
14189
14190 static const char *
14191 lang_printable_name (tree decl, int v)
14192 {
14193   /* Just to keep GCC quiet about the unused variable.
14194      In theory, differing values of V should produce different
14195      output.  */
14196   switch (v)
14197     {
14198     default:
14199       if (TREE_CODE (decl) == ERROR_MARK)
14200         return "erroneous code";
14201       return IDENTIFIER_POINTER (DECL_NAME (decl));
14202     }
14203 }
14204
14205 /* g77's function to print out name of current function that caused
14206    an error.  */
14207
14208 #if BUILT_FOR_270
14209 static void
14210 lang_print_error_function (const char *file)
14211 {
14212   static ffeglobal last_g = NULL;
14213   static ffesymbol last_s = NULL;
14214   ffeglobal g;
14215   ffesymbol s;
14216   const char *kind;
14217
14218   if ((ffecom_primary_entry_ == NULL)
14219       || (ffesymbol_global (ffecom_primary_entry_) == NULL))
14220     {
14221       g = NULL;
14222       s = NULL;
14223       kind = NULL;
14224     }
14225   else
14226     {
14227       g = ffesymbol_global (ffecom_primary_entry_);
14228       if (ffecom_nested_entry_ == NULL)
14229         {
14230           s = ffecom_primary_entry_;
14231           switch (ffesymbol_kind (s))
14232             {
14233             case FFEINFO_kindFUNCTION:
14234               kind = "function";
14235               break;
14236
14237             case FFEINFO_kindSUBROUTINE:
14238               kind = "subroutine";
14239               break;
14240
14241             case FFEINFO_kindPROGRAM:
14242               kind = "program";
14243               break;
14244
14245             case FFEINFO_kindBLOCKDATA:
14246               kind = "block-data";
14247               break;
14248
14249             default:
14250               kind = ffeinfo_kind_message (ffesymbol_kind (s));
14251               break;
14252             }
14253         }
14254       else
14255         {
14256           s = ffecom_nested_entry_;
14257           kind = "statement function";
14258         }
14259     }
14260
14261   if ((last_g != g) || (last_s != s))
14262     {
14263       if (file)
14264         fprintf (stderr, "%s: ", file);
14265
14266       if (s == NULL)
14267         fprintf (stderr, "Outside of any program unit:\n");
14268       else
14269         {
14270           const char *name = ffesymbol_text (s);
14271
14272           fprintf (stderr, "In %s `%s':\n", kind, name);
14273         }
14274
14275       last_g = g;
14276       last_s = s;
14277     }
14278 }
14279 #endif
14280
14281 /* Similar to `lookup_name' but look only at current binding level.  */
14282
14283 static tree
14284 lookup_name_current_level (tree name)
14285 {
14286   register tree t;
14287
14288   if (current_binding_level == global_binding_level)
14289     return IDENTIFIER_GLOBAL_VALUE (name);
14290
14291   if (IDENTIFIER_LOCAL_VALUE (name) == 0)
14292     return 0;
14293
14294   for (t = current_binding_level->names; t; t = TREE_CHAIN (t))
14295     if (DECL_NAME (t) == name)
14296       break;
14297
14298   return t;
14299 }
14300
14301 /* Create a new `struct binding_level'.  */
14302
14303 static struct binding_level *
14304 make_binding_level ()
14305 {
14306   /* NOSTRICT */
14307   return (struct binding_level *) xmalloc (sizeof (struct binding_level));
14308 }
14309
14310 /* Save and restore the variables in this file and elsewhere
14311    that keep track of the progress of compilation of the current function.
14312    Used for nested functions.  */
14313
14314 struct f_function
14315 {
14316   struct f_function *next;
14317   tree named_labels;
14318   tree shadowed_labels;
14319   struct binding_level *binding_level;
14320 };
14321
14322 struct f_function *f_function_chain;
14323
14324 /* Restore the variables used during compilation of a C function.  */
14325
14326 static void
14327 pop_f_function_context ()
14328 {
14329   struct f_function *p = f_function_chain;
14330   tree link;
14331
14332   /* Bring back all the labels that were shadowed.  */
14333   for (link = shadowed_labels; link; link = TREE_CHAIN (link))
14334     if (DECL_NAME (TREE_VALUE (link)) != 0)
14335       IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link)))
14336         = TREE_VALUE (link);
14337
14338   if (current_function_decl != error_mark_node
14339       && DECL_SAVED_INSNS (current_function_decl) == 0)
14340     {
14341       /* Stop pointing to the local nodes about to be freed.  */
14342       /* But DECL_INITIAL must remain nonzero so we know this was an actual
14343          function definition.  */
14344       DECL_INITIAL (current_function_decl) = error_mark_node;
14345       DECL_ARGUMENTS (current_function_decl) = 0;
14346     }
14347
14348   pop_function_context ();
14349
14350   f_function_chain = p->next;
14351
14352   named_labels = p->named_labels;
14353   shadowed_labels = p->shadowed_labels;
14354   current_binding_level = p->binding_level;
14355
14356   free (p);
14357 }
14358
14359 /* Save and reinitialize the variables
14360    used during compilation of a C function.  */
14361
14362 static void
14363 push_f_function_context ()
14364 {
14365   struct f_function *p
14366   = (struct f_function *) xmalloc (sizeof (struct f_function));
14367
14368   push_function_context ();
14369
14370   p->next = f_function_chain;
14371   f_function_chain = p;
14372
14373   p->named_labels = named_labels;
14374   p->shadowed_labels = shadowed_labels;
14375   p->binding_level = current_binding_level;
14376 }
14377
14378 static void
14379 push_parm_decl (tree parm)
14380 {
14381   int old_immediate_size_expand = immediate_size_expand;
14382
14383   /* Don't try computing parm sizes now -- wait till fn is called.  */
14384
14385   immediate_size_expand = 0;
14386
14387   push_obstacks_nochange ();
14388
14389   /* Fill in arg stuff.  */
14390
14391   DECL_ARG_TYPE (parm) = TREE_TYPE (parm);
14392   DECL_ARG_TYPE_AS_WRITTEN (parm) = TREE_TYPE (parm);
14393   TREE_READONLY (parm) = 1;     /* All implementation args are read-only. */
14394
14395   parm = pushdecl (parm);
14396
14397   immediate_size_expand = old_immediate_size_expand;
14398
14399   finish_decl (parm, NULL_TREE, FALSE);
14400 }
14401
14402 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate.  */
14403
14404 static tree
14405 pushdecl_top_level (x)
14406      tree x;
14407 {
14408   register tree t;
14409   register struct binding_level *b = current_binding_level;
14410   register tree f = current_function_decl;
14411
14412   current_binding_level = global_binding_level;
14413   current_function_decl = NULL_TREE;
14414   t = pushdecl (x);
14415   current_binding_level = b;
14416   current_function_decl = f;
14417   return t;
14418 }
14419
14420 /* Store the list of declarations of the current level.
14421    This is done for the parameter declarations of a function being defined,
14422    after they are modified in the light of any missing parameters.  */
14423
14424 static tree
14425 storedecls (decls)
14426      tree decls;
14427 {
14428   return current_binding_level->names = decls;
14429 }
14430
14431 /* Store the parameter declarations into the current function declaration.
14432    This is called after parsing the parameter declarations, before
14433    digesting the body of the function.
14434
14435    For an old-style definition, modify the function's type
14436    to specify at least the number of arguments.  */
14437
14438 static void
14439 store_parm_decls (int is_main_program UNUSED)
14440 {
14441   register tree fndecl = current_function_decl;
14442
14443   if (fndecl == error_mark_node)
14444     return;
14445
14446   /* This is a chain of PARM_DECLs from old-style parm declarations.  */
14447   DECL_ARGUMENTS (fndecl) = storedecls (nreverse (getdecls ()));
14448
14449   /* Initialize the RTL code for the function.  */
14450
14451   init_function_start (fndecl, input_filename, lineno);
14452
14453   /* Set up parameters and prepare for return, for the function.  */
14454
14455   expand_function_start (fndecl, 0);
14456 }
14457
14458 static tree
14459 start_decl (tree decl, bool is_top_level)
14460 {
14461   register tree tem;
14462   bool at_top_level = (current_binding_level == global_binding_level);
14463   bool top_level = is_top_level || at_top_level;
14464
14465   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
14466      level anyway.  */
14467   assert (!is_top_level || !at_top_level);
14468
14469   /* The corresponding pop_obstacks is in finish_decl.  */
14470   push_obstacks_nochange ();
14471
14472   if (DECL_INITIAL (decl) != NULL_TREE)
14473     {
14474       assert (DECL_INITIAL (decl) == error_mark_node);
14475       assert (!DECL_EXTERNAL (decl));
14476     }
14477   else if (top_level)
14478     assert ((TREE_STATIC (decl) == 1) || DECL_EXTERNAL (decl) == 1);
14479
14480   /* For Fortran, we by default put things in .common when possible.  */
14481   DECL_COMMON (decl) = 1;
14482
14483   /* Add this decl to the current binding level. TEM may equal DECL or it may
14484      be a previous decl of the same name.  */
14485   if (is_top_level)
14486     tem = pushdecl_top_level (decl);
14487   else
14488     tem = pushdecl (decl);
14489
14490   /* For a local variable, define the RTL now.  */
14491   if (!top_level
14492   /* But not if this is a duplicate decl and we preserved the rtl from the
14493      previous one (which may or may not happen).  */
14494       && DECL_RTL (tem) == 0)
14495     {
14496       if (TYPE_SIZE (TREE_TYPE (tem)) != 0)
14497         expand_decl (tem);
14498       else if (TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE
14499                && DECL_INITIAL (tem) != 0)
14500         expand_decl (tem);
14501     }
14502
14503   if (DECL_INITIAL (tem) != NULL_TREE)
14504     {
14505       /* When parsing and digesting the initializer, use temporary storage.
14506          Do this even if we will ignore the value.  */
14507       if (at_top_level)
14508         temporary_allocation ();
14509     }
14510
14511   return tem;
14512 }
14513
14514 /* Create the FUNCTION_DECL for a function definition.
14515    DECLSPECS and DECLARATOR are the parts of the declaration;
14516    they describe the function's name and the type it returns,
14517    but twisted together in a fashion that parallels the syntax of C.
14518
14519    This function creates a binding context for the function body
14520    as well as setting up the FUNCTION_DECL in current_function_decl.
14521
14522    Returns 1 on success.  If the DECLARATOR is not suitable for a function
14523    (it defines a datum instead), we return 0, which tells
14524    yyparse to report a parse error.
14525
14526    NESTED is nonzero for a function nested within another function.  */
14527
14528 static void
14529 start_function (tree name, tree type, int nested, int public)
14530 {
14531   tree decl1;
14532   tree restype;
14533   int old_immediate_size_expand = immediate_size_expand;
14534
14535   named_labels = 0;
14536   shadowed_labels = 0;
14537
14538   /* Don't expand any sizes in the return type of the function.  */
14539   immediate_size_expand = 0;
14540
14541   if (nested)
14542     {
14543       assert (!public);
14544       assert (current_function_decl != NULL_TREE);
14545       assert (DECL_CONTEXT (current_function_decl) == NULL_TREE);
14546     }
14547   else
14548     {
14549       assert (current_function_decl == NULL_TREE);
14550     }
14551
14552   if (TREE_CODE (type) == ERROR_MARK)
14553     decl1 = current_function_decl = error_mark_node;
14554   else
14555     {
14556       decl1 = build_decl (FUNCTION_DECL,
14557                           name,
14558                           type);
14559       TREE_PUBLIC (decl1) = public ? 1 : 0;
14560       if (nested)
14561         DECL_INLINE (decl1) = 1;
14562       TREE_STATIC (decl1) = 1;
14563       DECL_EXTERNAL (decl1) = 0;
14564
14565       announce_function (decl1);
14566
14567       /* Make the init_value nonzero so pushdecl knows this is not tentative.
14568          error_mark_node is replaced below (in poplevel) with the BLOCK.  */
14569       DECL_INITIAL (decl1) = error_mark_node;
14570
14571       /* Record the decl so that the function name is defined. If we already have
14572          a decl for this name, and it is a FUNCTION_DECL, use the old decl.  */
14573
14574       current_function_decl = pushdecl (decl1);
14575     }
14576
14577   if (!nested)
14578     ffecom_outer_function_decl_ = current_function_decl;
14579
14580   pushlevel (0);
14581   current_binding_level->prep_state = 2;
14582
14583   if (TREE_CODE (current_function_decl) != ERROR_MARK)
14584     {
14585       make_function_rtl (current_function_decl);
14586
14587       restype = TREE_TYPE (TREE_TYPE (current_function_decl));
14588       DECL_RESULT (current_function_decl)
14589         = build_decl (RESULT_DECL, NULL_TREE, restype);
14590     }
14591
14592   if (!nested)
14593     /* Allocate further tree nodes temporarily during compilation of this
14594        function only.  */
14595     temporary_allocation ();
14596
14597   if (!nested && (TREE_CODE (current_function_decl) != ERROR_MARK))
14598     TREE_ADDRESSABLE (current_function_decl) = 1;
14599
14600   immediate_size_expand = old_immediate_size_expand;
14601 }
14602 \f
14603 /* Here are the public functions the GNU back end needs.  */
14604
14605 tree
14606 convert (type, expr)
14607      tree type, expr;
14608 {
14609   register tree e = expr;
14610   register enum tree_code code = TREE_CODE (type);
14611
14612   if (type == TREE_TYPE (e)
14613       || TREE_CODE (e) == ERROR_MARK)
14614     return e;
14615   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
14616     return fold (build1 (NOP_EXPR, type, e));
14617   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
14618       || code == ERROR_MARK)
14619     return error_mark_node;
14620   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
14621     {
14622       assert ("void value not ignored as it ought to be" == NULL);
14623       return error_mark_node;
14624     }
14625   if (code == VOID_TYPE)
14626     return build1 (CONVERT_EXPR, type, e);
14627   if ((code != RECORD_TYPE)
14628       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
14629     e = ffecom_1 (REALPART_EXPR, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))),
14630                   e);
14631   if (code == INTEGER_TYPE || code == ENUMERAL_TYPE)
14632     return fold (convert_to_integer (type, e));
14633   if (code == POINTER_TYPE)
14634     return fold (convert_to_pointer (type, e));
14635   if (code == REAL_TYPE)
14636     return fold (convert_to_real (type, e));
14637   if (code == COMPLEX_TYPE)
14638     return fold (convert_to_complex (type, e));
14639   if (code == RECORD_TYPE)
14640     return fold (ffecom_convert_to_complex_ (type, e));
14641
14642   assert ("conversion to non-scalar type requested" == NULL);
14643   return error_mark_node;
14644 }
14645
14646 /* integrate_decl_tree calls this function, but since we don't use the
14647    DECL_LANG_SPECIFIC field, this is a no-op.  */
14648
14649 void
14650 copy_lang_decl (node)
14651      tree node UNUSED;
14652 {
14653 }
14654
14655 /* Return the list of declarations of the current level.
14656    Note that this list is in reverse order unless/until
14657    you nreverse it; and when you do nreverse it, you must
14658    store the result back using `storedecls' or you will lose.  */
14659
14660 tree
14661 getdecls ()
14662 {
14663   return current_binding_level->names;
14664 }
14665
14666 /* Nonzero if we are currently in the global binding level.  */
14667
14668 int
14669 global_bindings_p ()
14670 {
14671   return current_binding_level == global_binding_level;
14672 }
14673
14674 /* Print an error message for invalid use of an incomplete type.
14675    VALUE is the expression that was used (or 0 if that isn't known)
14676    and TYPE is the type that was invalid.  */
14677
14678 void
14679 incomplete_type_error (value, type)
14680      tree value UNUSED;
14681      tree type;
14682 {
14683   if (TREE_CODE (type) == ERROR_MARK)
14684     return;
14685
14686   assert ("incomplete type?!?" == NULL);
14687 }
14688
14689 /* Mark ARG for GC.  */
14690 static void
14691 mark_binding_level (void *arg)
14692 {
14693   struct binding_level *level = *(struct binding_level **) arg;
14694
14695   while (level)
14696     {
14697       ggc_mark_tree (level->names);
14698       ggc_mark_tree (level->blocks);
14699       ggc_mark_tree (level->this_block);
14700       level = level->level_chain;
14701     }
14702 }
14703
14704 void
14705 init_decl_processing ()
14706 {
14707   static tree *const tree_roots[] = {
14708     &current_function_decl,
14709     &string_type_node,
14710     &ffecom_tree_fun_type_void,
14711     &ffecom_integer_zero_node,
14712     &ffecom_integer_one_node,
14713     &ffecom_tree_subr_type,
14714     &ffecom_tree_ptr_to_subr_type,
14715     &ffecom_tree_blockdata_type,
14716     &ffecom_tree_xargc_,
14717     &ffecom_f2c_integer_type_node,
14718     &ffecom_f2c_ptr_to_integer_type_node,
14719     &ffecom_f2c_address_type_node,
14720     &ffecom_f2c_real_type_node,
14721     &ffecom_f2c_ptr_to_real_type_node,
14722     &ffecom_f2c_doublereal_type_node,
14723     &ffecom_f2c_complex_type_node,
14724     &ffecom_f2c_doublecomplex_type_node,
14725     &ffecom_f2c_longint_type_node,
14726     &ffecom_f2c_logical_type_node,
14727     &ffecom_f2c_flag_type_node,
14728     &ffecom_f2c_ftnlen_type_node,
14729     &ffecom_f2c_ftnlen_zero_node,
14730     &ffecom_f2c_ftnlen_one_node,
14731     &ffecom_f2c_ftnlen_two_node,
14732     &ffecom_f2c_ptr_to_ftnlen_type_node,
14733     &ffecom_f2c_ftnint_type_node,
14734     &ffecom_f2c_ptr_to_ftnint_type_node,
14735     &ffecom_outer_function_decl_,
14736     &ffecom_previous_function_decl_,
14737     &ffecom_which_entrypoint_decl_,
14738     &ffecom_float_zero_,
14739     &ffecom_float_half_,
14740     &ffecom_double_zero_,
14741     &ffecom_double_half_,
14742     &ffecom_func_result_,
14743     &ffecom_func_length_,
14744     &ffecom_multi_type_node_,
14745     &ffecom_multi_retval_,
14746     &named_labels,
14747     &shadowed_labels
14748   };
14749   size_t i;
14750
14751   malloc_init ();
14752
14753   /* Record our roots.  */
14754   for (i = 0; i < sizeof(tree_roots)/sizeof(tree_roots[0]); i++)
14755     ggc_add_tree_root (tree_roots[i], 1);
14756   ggc_add_tree_root (&ffecom_tree_type[0][0],
14757                      FFEINFO_basictype*FFEINFO_kindtype);
14758   ggc_add_tree_root (&ffecom_tree_fun_type[0][0],
14759                      FFEINFO_basictype*FFEINFO_kindtype);
14760   ggc_add_tree_root (&ffecom_tree_ptr_to_fun_type[0][0],
14761                      FFEINFO_basictype*FFEINFO_kindtype);
14762   ggc_add_tree_root (ffecom_gfrt_, FFECOM_gfrt);
14763   ggc_add_root (&current_binding_level, 1, sizeof current_binding_level,
14764                 mark_binding_level);
14765   ggc_add_root (&free_binding_level, 1, sizeof current_binding_level,
14766                 mark_binding_level);
14767   ggc_add_root (&tracker_head, 1, sizeof tracker_head, mark_tracker_head);
14768
14769   ffe_init_0 ();
14770 }
14771
14772 const char *
14773 init_parse (filename)
14774      const char *filename;
14775 {
14776   /* Open input file.  */
14777   if (filename == 0 || !strcmp (filename, "-"))
14778     {
14779       finput = stdin;
14780       filename = "stdin";
14781     }
14782   else
14783     finput = fopen (filename, "r");
14784   if (finput == 0)
14785     pfatal_with_name (filename);
14786
14787 #ifdef IO_BUFFER_SIZE
14788   setvbuf (finput, (char *) xmalloc (IO_BUFFER_SIZE), _IOFBF, IO_BUFFER_SIZE);
14789 #endif
14790
14791   /* Make identifier nodes long enough for the language-specific slots.  */
14792   set_identifier_size (sizeof (struct lang_identifier));
14793   decl_printable_name = lang_printable_name;
14794 #if BUILT_FOR_270
14795   print_error_function = lang_print_error_function;
14796 #endif
14797
14798   return filename;
14799 }
14800
14801 void
14802 finish_parse ()
14803 {
14804   fclose (finput);
14805 }
14806
14807 /* Delete the node BLOCK from the current binding level.
14808    This is used for the block inside a stmt expr ({...})
14809    so that the block can be reinserted where appropriate.  */
14810
14811 static void
14812 delete_block (block)
14813      tree block;
14814 {
14815   tree t;
14816   if (current_binding_level->blocks == block)
14817     current_binding_level->blocks = TREE_CHAIN (block);
14818   for (t = current_binding_level->blocks; t;)
14819     {
14820       if (TREE_CHAIN (t) == block)
14821         TREE_CHAIN (t) = TREE_CHAIN (block);
14822       else
14823         t = TREE_CHAIN (t);
14824     }
14825   TREE_CHAIN (block) = NULL;
14826   /* Clear TREE_USED which is always set by poplevel.
14827      The flag is set again if insert_block is called.  */
14828   TREE_USED (block) = 0;
14829 }
14830
14831 void
14832 insert_block (block)
14833      tree block;
14834 {
14835   TREE_USED (block) = 1;
14836   current_binding_level->blocks
14837     = chainon (current_binding_level->blocks, block);
14838 }
14839
14840 int
14841 lang_decode_option (argc, argv)
14842      int argc;
14843      char **argv;
14844 {
14845   return ffe_decode_option (argc, argv);
14846 }
14847
14848 /* used by print-tree.c */
14849
14850 void
14851 lang_print_xnode (file, node, indent)
14852      FILE *file UNUSED;
14853      tree node UNUSED;
14854      int indent UNUSED;
14855 {
14856 }
14857
14858 void
14859 lang_finish ()
14860 {
14861   ffe_terminate_0 ();
14862
14863   if (ffe_is_ffedebug ())
14864     malloc_pool_display (malloc_pool_image ());
14865 }
14866
14867 const char *
14868 lang_identify ()
14869 {
14870   return "f77";
14871 }
14872
14873 /* Return the typed-based alias set for T, which may be an expression
14874    or a type.  Return -1 if we don't do anything special.  */
14875
14876 HOST_WIDE_INT
14877 lang_get_alias_set (t)
14878      tree t ATTRIBUTE_UNUSED;
14879 {
14880   /* We do not wish to use alias-set based aliasing at all.  Used in the
14881      extreme (every object with its own set, with equivalences recorded)
14882      it might be helpful, but there are problems when it comes to inlining.
14883      We get on ok with flag_argument_noalias, and alias-set aliasing does
14884      currently limit how stack slots can be reused, which is a lose.  */
14885   return 0;
14886 }
14887
14888 void
14889 lang_init_options ()
14890 {
14891   /* Set default options for Fortran.  */
14892   flag_move_all_movables = 1;
14893   flag_reduce_all_givs = 1;
14894   flag_argument_noalias = 2;
14895   flag_errno_math = 0;
14896   flag_complex_divide_method = 1;
14897 }
14898
14899 void
14900 lang_init ()
14901 {
14902   /* If the file is output from cpp, it should contain a first line
14903      `# 1 "real-filename"', and the current design of gcc (toplev.c
14904      in particular and the way it sets up information relied on by
14905      INCLUDE) requires that we read this now, and store the
14906      "real-filename" info in master_input_filename.  Ask the lexer
14907      to try doing this.  */
14908   ffelex_hash_kludge (finput);
14909 }
14910
14911 int
14912 mark_addressable (exp)
14913      tree exp;
14914 {
14915   register tree x = exp;
14916   while (1)
14917     switch (TREE_CODE (x))
14918       {
14919       case ADDR_EXPR:
14920       case COMPONENT_REF:
14921       case ARRAY_REF:
14922         x = TREE_OPERAND (x, 0);
14923         break;
14924
14925       case CONSTRUCTOR:
14926         TREE_ADDRESSABLE (x) = 1;
14927         return 1;
14928
14929       case VAR_DECL:
14930       case CONST_DECL:
14931       case PARM_DECL:
14932       case RESULT_DECL:
14933         if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)
14934             && DECL_NONLOCAL (x))
14935           {
14936             if (TREE_PUBLIC (x))
14937               {
14938                 assert ("address of global register var requested" == NULL);
14939                 return 0;
14940               }
14941             assert ("address of register variable requested" == NULL);
14942           }
14943         else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
14944           {
14945             if (TREE_PUBLIC (x))
14946               {
14947                 assert ("address of global register var requested" == NULL);
14948                 return 0;
14949               }
14950             assert ("address of register var requested" == NULL);
14951           }
14952         put_var_into_stack (x);
14953
14954         /* drops in */
14955       case FUNCTION_DECL:
14956         TREE_ADDRESSABLE (x) = 1;
14957 #if 0                           /* poplevel deals with this now.  */
14958         if (DECL_CONTEXT (x) == 0)
14959           TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1;
14960 #endif
14961
14962       default:
14963         return 1;
14964       }
14965 }
14966
14967 /* If DECL has a cleanup, build and return that cleanup here.
14968    This is a callback called by expand_expr.  */
14969
14970 tree
14971 maybe_build_cleanup (decl)
14972      tree decl UNUSED;
14973 {
14974   /* There are no cleanups in Fortran.  */
14975   return NULL_TREE;
14976 }
14977
14978 /* Exit a binding level.
14979    Pop the level off, and restore the state of the identifier-decl mappings
14980    that were in effect when this level was entered.
14981
14982    If KEEP is nonzero, this level had explicit declarations, so
14983    and create a "block" (a BLOCK node) for the level
14984    to record its declarations and subblocks for symbol table output.
14985
14986    If FUNCTIONBODY is nonzero, this level is the body of a function,
14987    so create a block as if KEEP were set and also clear out all
14988    label names.
14989
14990    If REVERSE is nonzero, reverse the order of decls before putting
14991    them into the BLOCK.  */
14992
14993 tree
14994 poplevel (keep, reverse, functionbody)
14995      int keep;
14996      int reverse;
14997      int functionbody;
14998 {
14999   register tree link;
15000   /* The chain of decls was accumulated in reverse order.
15001      Put it into forward order, just for cleanliness.  */
15002   tree decls;
15003   tree subblocks = current_binding_level->blocks;
15004   tree block = 0;
15005   tree decl;
15006   int block_previously_created;
15007
15008   /* Get the decls in the order they were written.
15009      Usually current_binding_level->names is in reverse order.
15010      But parameter decls were previously put in forward order.  */
15011
15012   if (reverse)
15013     current_binding_level->names
15014       = decls = nreverse (current_binding_level->names);
15015   else
15016     decls = current_binding_level->names;
15017
15018   /* Output any nested inline functions within this block
15019      if they weren't already output.  */
15020
15021   for (decl = decls; decl; decl = TREE_CHAIN (decl))
15022     if (TREE_CODE (decl) == FUNCTION_DECL
15023         && ! TREE_ASM_WRITTEN (decl)
15024         && DECL_INITIAL (decl) != 0
15025         && TREE_ADDRESSABLE (decl))
15026       {
15027         /* If this decl was copied from a file-scope decl
15028            on account of a block-scope extern decl,
15029            propagate TREE_ADDRESSABLE to the file-scope decl.
15030
15031            DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
15032            true, since then the decl goes through save_for_inline_copying.  */
15033         if (DECL_ABSTRACT_ORIGIN (decl) != 0
15034             && DECL_ABSTRACT_ORIGIN (decl) != decl)
15035           TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1;
15036         else if (DECL_SAVED_INSNS (decl) != 0)
15037           {
15038             push_function_context ();
15039             output_inline_function (decl);
15040             pop_function_context ();
15041           }
15042       }
15043
15044   /* If there were any declarations or structure tags in that level,
15045      or if this level is a function body,
15046      create a BLOCK to record them for the life of this function.  */
15047
15048   block = 0;
15049   block_previously_created = (current_binding_level->this_block != 0);
15050   if (block_previously_created)
15051     block = current_binding_level->this_block;
15052   else if (keep || functionbody)
15053     block = make_node (BLOCK);
15054   if (block != 0)
15055     {
15056       BLOCK_VARS (block) = decls;
15057       BLOCK_SUBBLOCKS (block) = subblocks;
15058     }
15059
15060   /* In each subblock, record that this is its superior.  */
15061
15062   for (link = subblocks; link; link = TREE_CHAIN (link))
15063     BLOCK_SUPERCONTEXT (link) = block;
15064
15065   /* Clear out the meanings of the local variables of this level.  */
15066
15067   for (link = decls; link; link = TREE_CHAIN (link))
15068     {
15069       if (DECL_NAME (link) != 0)
15070         {
15071           /* If the ident. was used or addressed via a local extern decl,
15072              don't forget that fact.  */
15073           if (DECL_EXTERNAL (link))
15074             {
15075               if (TREE_USED (link))
15076                 TREE_USED (DECL_NAME (link)) = 1;
15077               if (TREE_ADDRESSABLE (link))
15078                 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link)) = 1;
15079             }
15080           IDENTIFIER_LOCAL_VALUE (DECL_NAME (link)) = 0;
15081         }
15082     }
15083
15084   /* If the level being exited is the top level of a function,
15085      check over all the labels, and clear out the current
15086      (function local) meanings of their names.  */
15087
15088   if (functionbody)
15089     {
15090       /* If this is the top level block of a function,
15091          the vars are the function's parameters.
15092          Don't leave them in the BLOCK because they are
15093          found in the FUNCTION_DECL instead.  */
15094
15095       BLOCK_VARS (block) = 0;
15096     }
15097
15098   /* Pop the current level, and free the structure for reuse.  */
15099
15100   {
15101     register struct binding_level *level = current_binding_level;
15102     current_binding_level = current_binding_level->level_chain;
15103
15104     level->level_chain = free_binding_level;
15105     free_binding_level = level;
15106   }
15107
15108   /* Dispose of the block that we just made inside some higher level.  */
15109   if (functionbody
15110       && current_function_decl != error_mark_node)
15111     DECL_INITIAL (current_function_decl) = block;
15112   else if (block)
15113     {
15114       if (!block_previously_created)
15115         current_binding_level->blocks
15116           = chainon (current_binding_level->blocks, block);
15117     }
15118   /* If we did not make a block for the level just exited,
15119      any blocks made for inner levels
15120      (since they cannot be recorded as subblocks in that level)
15121      must be carried forward so they will later become subblocks
15122      of something else.  */
15123   else if (subblocks)
15124     current_binding_level->blocks
15125       = chainon (current_binding_level->blocks, subblocks);
15126
15127   if (block)
15128     TREE_USED (block) = 1;
15129   return block;
15130 }
15131
15132 void
15133 print_lang_decl (file, node, indent)
15134      FILE *file UNUSED;
15135      tree node UNUSED;
15136      int indent UNUSED;
15137 {
15138 }
15139
15140 void
15141 print_lang_identifier (file, node, indent)
15142      FILE *file;
15143      tree node;
15144      int indent;
15145 {
15146   print_node (file, "global", IDENTIFIER_GLOBAL_VALUE (node), indent + 4);
15147   print_node (file, "local", IDENTIFIER_LOCAL_VALUE (node), indent + 4);
15148 }
15149
15150 void
15151 print_lang_statistics ()
15152 {
15153 }
15154
15155 void
15156 print_lang_type (file, node, indent)
15157      FILE *file UNUSED;
15158      tree node UNUSED;
15159      int indent UNUSED;
15160 {
15161 }
15162
15163 /* Record a decl-node X as belonging to the current lexical scope.
15164    Check for errors (such as an incompatible declaration for the same
15165    name already seen in the same scope).
15166
15167    Returns either X or an old decl for the same name.
15168    If an old decl is returned, it may have been smashed
15169    to agree with what X says.  */
15170
15171 tree
15172 pushdecl (x)
15173      tree x;
15174 {
15175   register tree t;
15176   register tree name = DECL_NAME (x);
15177   register struct binding_level *b = current_binding_level;
15178
15179   if ((TREE_CODE (x) == FUNCTION_DECL)
15180       && (DECL_INITIAL (x) == 0)
15181       && DECL_EXTERNAL (x))
15182     DECL_CONTEXT (x) = NULL_TREE;
15183   else
15184     DECL_CONTEXT (x) = current_function_decl;
15185
15186   if (name)
15187     {
15188       if (IDENTIFIER_INVENTED (name))
15189         {
15190 #if BUILT_FOR_270
15191           DECL_ARTIFICIAL (x) = 1;
15192 #endif
15193           DECL_IN_SYSTEM_HEADER (x) = 1;
15194         }
15195
15196       t = lookup_name_current_level (name);
15197
15198       assert ((t == NULL_TREE) || (DECL_CONTEXT (x) == NULL_TREE));
15199
15200       /* Don't push non-parms onto list for parms until we understand
15201          why we're doing this and whether it works.  */
15202
15203       assert ((b == global_binding_level)
15204               || !ffecom_transform_only_dummies_
15205               || TREE_CODE (x) == PARM_DECL);
15206
15207       if ((t != NULL_TREE) && duplicate_decls (x, t))
15208         return t;
15209
15210       /* If we are processing a typedef statement, generate a whole new
15211          ..._TYPE node (which will be just an variant of the existing
15212          ..._TYPE node with identical properties) and then install the
15213          TYPE_DECL node generated to represent the typedef name as the
15214          TYPE_NAME of this brand new (duplicate) ..._TYPE node.
15215
15216          The whole point here is to end up with a situation where each and every
15217          ..._TYPE node the compiler creates will be uniquely associated with
15218          AT MOST one node representing a typedef name. This way, even though
15219          the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
15220          (i.e. "typedef name") nodes very early on, later parts of the
15221          compiler can always do the reverse translation and get back the
15222          corresponding typedef name.  For example, given:
15223
15224          typedef struct S MY_TYPE; MY_TYPE object;
15225
15226          Later parts of the compiler might only know that `object' was of type
15227          `struct S' if it were not for code just below.  With this code
15228          however, later parts of the compiler see something like:
15229
15230          struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
15231
15232          And they can then deduce (from the node for type struct S') that the
15233          original object declaration was:
15234
15235          MY_TYPE object;
15236
15237          Being able to do this is important for proper support of protoize, and
15238          also for generating precise symbolic debugging information which
15239          takes full account of the programmer's (typedef) vocabulary.
15240
15241          Obviously, we don't want to generate a duplicate ..._TYPE node if the
15242          TYPE_DECL node that we are now processing really represents a
15243          standard built-in type.
15244
15245          Since all standard types are effectively declared at line zero in the
15246          source file, we can easily check to see if we are working on a
15247          standard type by checking the current value of lineno.  */
15248
15249       if (TREE_CODE (x) == TYPE_DECL)
15250         {
15251           if (DECL_SOURCE_LINE (x) == 0)
15252             {
15253               if (TYPE_NAME (TREE_TYPE (x)) == 0)
15254                 TYPE_NAME (TREE_TYPE (x)) = x;
15255             }
15256           else if (TREE_TYPE (x) != error_mark_node)
15257             {
15258               tree tt = TREE_TYPE (x);
15259
15260               tt = build_type_copy (tt);
15261               TYPE_NAME (tt) = x;
15262               TREE_TYPE (x) = tt;
15263             }
15264         }
15265
15266       /* This name is new in its binding level. Install the new declaration
15267          and return it.  */
15268       if (b == global_binding_level)
15269         IDENTIFIER_GLOBAL_VALUE (name) = x;
15270       else
15271         IDENTIFIER_LOCAL_VALUE (name) = x;
15272     }
15273
15274   /* Put decls on list in reverse order. We will reverse them later if
15275      necessary.  */
15276   TREE_CHAIN (x) = b->names;
15277   b->names = x;
15278
15279   return x;
15280 }
15281
15282 /* Nonzero if the current level needs to have a BLOCK made.  */
15283
15284 static int
15285 kept_level_p ()
15286 {
15287   tree decl;
15288
15289   for (decl = current_binding_level->names;
15290        decl;
15291        decl = TREE_CHAIN (decl))
15292     {
15293       if (TREE_USED (decl) || TREE_CODE (decl) != VAR_DECL
15294           || (DECL_NAME (decl) && ! DECL_ARTIFICIAL (decl)))
15295         /* Currently, there aren't supposed to be non-artificial names
15296            at other than the top block for a function -- they're
15297            believed to always be temps.  But it's wise to check anyway.  */
15298         return 1;
15299     }
15300   return 0;
15301 }
15302
15303 /* Enter a new binding level.
15304    If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
15305    not for that of tags.  */
15306
15307 void
15308 pushlevel (tag_transparent)
15309      int tag_transparent;
15310 {
15311   register struct binding_level *newlevel = NULL_BINDING_LEVEL;
15312
15313   assert (! tag_transparent);
15314
15315   if (current_binding_level == global_binding_level)
15316     {
15317       named_labels = 0;
15318     }
15319
15320   /* Reuse or create a struct for this binding level.  */
15321
15322   if (free_binding_level)
15323     {
15324       newlevel = free_binding_level;
15325       free_binding_level = free_binding_level->level_chain;
15326     }
15327   else
15328     {
15329       newlevel = make_binding_level ();
15330     }
15331
15332   /* Add this level to the front of the chain (stack) of levels that
15333      are active.  */
15334
15335   *newlevel = clear_binding_level;
15336   newlevel->level_chain = current_binding_level;
15337   current_binding_level = newlevel;
15338 }
15339
15340 /* Set the BLOCK node for the innermost scope
15341    (the one we are currently in).  */
15342
15343 void
15344 set_block (block)
15345      register tree block;
15346 {
15347   current_binding_level->this_block = block;
15348 }
15349
15350 /* ~~gcc/tree.h *should* declare this, because toplev.c references it.  */
15351
15352 /* Can't 'yydebug' a front end not generated by yacc/bison!  */
15353
15354 void
15355 set_yydebug (value)
15356      int value;
15357 {
15358   if (value)
15359     fprintf (stderr, "warning: no yacc/bison-generated output to debug!\n");
15360 }
15361
15362 tree
15363 signed_or_unsigned_type (unsignedp, type)
15364      int unsignedp;
15365      tree type;
15366 {
15367   tree type2;
15368
15369   if (! INTEGRAL_TYPE_P (type))
15370     return type;
15371   if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
15372     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15373   if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
15374     return unsignedp ? unsigned_type_node : integer_type_node;
15375   if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
15376     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15377   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
15378     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15379   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
15380     return (unsignedp ? long_long_unsigned_type_node
15381             : long_long_integer_type_node);
15382
15383   type2 = type_for_size (TYPE_PRECISION (type), unsignedp);
15384   if (type2 == NULL_TREE)
15385     return type;
15386
15387   return type2;
15388 }
15389
15390 tree
15391 signed_type (type)
15392      tree type;
15393 {
15394   tree type1 = TYPE_MAIN_VARIANT (type);
15395   ffeinfoKindtype kt;
15396   tree type2;
15397
15398   if (type1 == unsigned_char_type_node || type1 == char_type_node)
15399     return signed_char_type_node;
15400   if (type1 == unsigned_type_node)
15401     return integer_type_node;
15402   if (type1 == short_unsigned_type_node)
15403     return short_integer_type_node;
15404   if (type1 == long_unsigned_type_node)
15405     return long_integer_type_node;
15406   if (type1 == long_long_unsigned_type_node)
15407     return long_long_integer_type_node;
15408 #if 0   /* gcc/c-* files only */
15409   if (type1 == unsigned_intDI_type_node)
15410     return intDI_type_node;
15411   if (type1 == unsigned_intSI_type_node)
15412     return intSI_type_node;
15413   if (type1 == unsigned_intHI_type_node)
15414     return intHI_type_node;
15415   if (type1 == unsigned_intQI_type_node)
15416     return intQI_type_node;
15417 #endif
15418
15419   type2 = type_for_size (TYPE_PRECISION (type1), 0);
15420   if (type2 != NULL_TREE)
15421     return type2;
15422
15423   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15424     {
15425       type2 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15426
15427       if (type1 == type2)
15428         return ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15429     }
15430
15431   return type;
15432 }
15433
15434 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
15435    or validate its data type for an `if' or `while' statement or ?..: exp.
15436
15437    This preparation consists of taking the ordinary
15438    representation of an expression expr and producing a valid tree
15439    boolean expression describing whether expr is nonzero.  We could
15440    simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
15441    but we optimize comparisons, &&, ||, and !.
15442
15443    The resulting type should always be `integer_type_node'.  */
15444
15445 tree
15446 truthvalue_conversion (expr)
15447      tree expr;
15448 {
15449   if (TREE_CODE (expr) == ERROR_MARK)
15450     return expr;
15451
15452 #if 0 /* This appears to be wrong for C++.  */
15453   /* These really should return error_mark_node after 2.4 is stable.
15454      But not all callers handle ERROR_MARK properly.  */
15455   switch (TREE_CODE (TREE_TYPE (expr)))
15456     {
15457     case RECORD_TYPE:
15458       error ("struct type value used where scalar is required");
15459       return integer_zero_node;
15460
15461     case UNION_TYPE:
15462       error ("union type value used where scalar is required");
15463       return integer_zero_node;
15464
15465     case ARRAY_TYPE:
15466       error ("array type value used where scalar is required");
15467       return integer_zero_node;
15468
15469     default:
15470       break;
15471     }
15472 #endif /* 0 */
15473
15474   switch (TREE_CODE (expr))
15475     {
15476       /* It is simpler and generates better code to have only TRUTH_*_EXPR
15477          or comparison expressions as truth values at this level.  */
15478 #if 0
15479     case COMPONENT_REF:
15480       /* A one-bit unsigned bit-field is already acceptable.  */
15481       if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr, 1)))
15482           && TREE_UNSIGNED (TREE_OPERAND (expr, 1)))
15483         return expr;
15484       break;
15485 #endif
15486
15487     case EQ_EXPR:
15488       /* It is simpler and generates better code to have only TRUTH_*_EXPR
15489          or comparison expressions as truth values at this level.  */
15490 #if 0
15491       if (integer_zerop (TREE_OPERAND (expr, 1)))
15492         return build_unary_op (TRUTH_NOT_EXPR, TREE_OPERAND (expr, 0), 0);
15493 #endif
15494     case NE_EXPR: case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR:
15495     case TRUTH_ANDIF_EXPR:
15496     case TRUTH_ORIF_EXPR:
15497     case TRUTH_AND_EXPR:
15498     case TRUTH_OR_EXPR:
15499     case TRUTH_XOR_EXPR:
15500       TREE_TYPE (expr) = integer_type_node;
15501       return expr;
15502
15503     case ERROR_MARK:
15504       return expr;
15505
15506     case INTEGER_CST:
15507       return integer_zerop (expr) ? integer_zero_node : integer_one_node;
15508
15509     case REAL_CST:
15510       return real_zerop (expr) ? integer_zero_node : integer_one_node;
15511
15512     case ADDR_EXPR:
15513       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 0)))
15514         return build (COMPOUND_EXPR, integer_type_node,
15515                       TREE_OPERAND (expr, 0), integer_one_node);
15516       else
15517         return integer_one_node;
15518
15519     case COMPLEX_EXPR:
15520       return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1))
15521                         ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
15522                        integer_type_node,
15523                        truthvalue_conversion (TREE_OPERAND (expr, 0)),
15524                        truthvalue_conversion (TREE_OPERAND (expr, 1)));
15525
15526     case NEGATE_EXPR:
15527     case ABS_EXPR:
15528     case FLOAT_EXPR:
15529     case FFS_EXPR:
15530       /* These don't change whether an object is non-zero or zero.  */
15531       return truthvalue_conversion (TREE_OPERAND (expr, 0));
15532
15533     case LROTATE_EXPR:
15534     case RROTATE_EXPR:
15535       /* These don't change whether an object is zero or non-zero, but
15536          we can't ignore them if their second arg has side-effects.  */
15537       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)))
15538         return build (COMPOUND_EXPR, integer_type_node, TREE_OPERAND (expr, 1),
15539                       truthvalue_conversion (TREE_OPERAND (expr, 0)));
15540       else
15541         return truthvalue_conversion (TREE_OPERAND (expr, 0));
15542
15543     case COND_EXPR:
15544       /* Distribute the conversion into the arms of a COND_EXPR.  */
15545       return fold (build (COND_EXPR, integer_type_node, TREE_OPERAND (expr, 0),
15546                           truthvalue_conversion (TREE_OPERAND (expr, 1)),
15547                           truthvalue_conversion (TREE_OPERAND (expr, 2))));
15548
15549     case CONVERT_EXPR:
15550       /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
15551          since that affects how `default_conversion' will behave.  */
15552       if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE
15553           || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE)
15554         break;
15555       /* fall through... */
15556     case NOP_EXPR:
15557       /* If this is widening the argument, we can ignore it.  */
15558       if (TYPE_PRECISION (TREE_TYPE (expr))
15559           >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0))))
15560         return truthvalue_conversion (TREE_OPERAND (expr, 0));
15561       break;
15562
15563     case MINUS_EXPR:
15564       /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
15565          this case.  */
15566       if (TARGET_FLOAT_FORMAT == IEEE_FLOAT_FORMAT
15567           && TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE)
15568         break;
15569       /* fall through... */
15570     case BIT_XOR_EXPR:
15571       /* This and MINUS_EXPR can be changed into a comparison of the
15572          two objects.  */
15573       if (TREE_TYPE (TREE_OPERAND (expr, 0))
15574           == TREE_TYPE (TREE_OPERAND (expr, 1)))
15575         return ffecom_2 (NE_EXPR, integer_type_node,
15576                          TREE_OPERAND (expr, 0),
15577                          TREE_OPERAND (expr, 1));
15578       return ffecom_2 (NE_EXPR, integer_type_node,
15579                        TREE_OPERAND (expr, 0),
15580                        fold (build1 (NOP_EXPR,
15581                                      TREE_TYPE (TREE_OPERAND (expr, 0)),
15582                                      TREE_OPERAND (expr, 1))));
15583
15584     case BIT_AND_EXPR:
15585       if (integer_onep (TREE_OPERAND (expr, 1)))
15586         return expr;
15587       break;
15588
15589     case MODIFY_EXPR:
15590 #if 0                           /* No such thing in Fortran. */
15591       if (warn_parentheses && C_EXP_ORIGINAL_CODE (expr) == MODIFY_EXPR)
15592         warning ("suggest parentheses around assignment used as truth value");
15593 #endif
15594       break;
15595
15596     default:
15597       break;
15598     }
15599
15600   if (TREE_CODE (TREE_TYPE (expr)) == COMPLEX_TYPE)
15601     return (ffecom_2
15602             ((TREE_SIDE_EFFECTS (expr)
15603               ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
15604              integer_type_node,
15605              truthvalue_conversion (ffecom_1 (REALPART_EXPR,
15606                                               TREE_TYPE (TREE_TYPE (expr)),
15607                                               expr)),
15608              truthvalue_conversion (ffecom_1 (IMAGPART_EXPR,
15609                                               TREE_TYPE (TREE_TYPE (expr)),
15610                                               expr))));
15611
15612   return ffecom_2 (NE_EXPR, integer_type_node,
15613                    expr,
15614                    convert (TREE_TYPE (expr), integer_zero_node));
15615 }
15616
15617 tree
15618 type_for_mode (mode, unsignedp)
15619      enum machine_mode mode;
15620      int unsignedp;
15621 {
15622   int i;
15623   int j;
15624   tree t;
15625
15626   if (mode == TYPE_MODE (integer_type_node))
15627     return unsignedp ? unsigned_type_node : integer_type_node;
15628
15629   if (mode == TYPE_MODE (signed_char_type_node))
15630     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15631
15632   if (mode == TYPE_MODE (short_integer_type_node))
15633     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15634
15635   if (mode == TYPE_MODE (long_integer_type_node))
15636     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15637
15638   if (mode == TYPE_MODE (long_long_integer_type_node))
15639     return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node;
15640
15641 #if HOST_BITS_PER_WIDE_INT >= 64
15642   if (mode == TYPE_MODE (intTI_type_node))
15643     return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
15644 #endif
15645
15646   if (mode == TYPE_MODE (float_type_node))
15647     return float_type_node;
15648
15649   if (mode == TYPE_MODE (double_type_node))
15650     return double_type_node;
15651
15652   if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
15653     return build_pointer_type (char_type_node);
15654
15655   if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
15656     return build_pointer_type (integer_type_node);
15657
15658   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
15659     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
15660       {
15661         if (((t = ffecom_tree_type[i][j]) != NULL_TREE)
15662             && (mode == TYPE_MODE (t)))
15663           {
15664             if ((i == FFEINFO_basictypeINTEGER) && unsignedp)
15665               return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][j];
15666             else
15667               return t;
15668           }
15669       }
15670
15671   return 0;
15672 }
15673
15674 tree
15675 type_for_size (bits, unsignedp)
15676      unsigned bits;
15677      int unsignedp;
15678 {
15679   ffeinfoKindtype kt;
15680   tree type_node;
15681
15682   if (bits == TYPE_PRECISION (integer_type_node))
15683     return unsignedp ? unsigned_type_node : integer_type_node;
15684
15685   if (bits == TYPE_PRECISION (signed_char_type_node))
15686     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15687
15688   if (bits == TYPE_PRECISION (short_integer_type_node))
15689     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15690
15691   if (bits == TYPE_PRECISION (long_integer_type_node))
15692     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15693
15694   if (bits == TYPE_PRECISION (long_long_integer_type_node))
15695     return (unsignedp ? long_long_unsigned_type_node
15696             : long_long_integer_type_node);
15697
15698   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15699     {
15700       type_node = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15701
15702       if ((type_node != NULL_TREE) && (bits == TYPE_PRECISION (type_node)))
15703         return unsignedp ? ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]
15704           : type_node;
15705     }
15706
15707   return 0;
15708 }
15709
15710 tree
15711 unsigned_type (type)
15712      tree type;
15713 {
15714   tree type1 = TYPE_MAIN_VARIANT (type);
15715   ffeinfoKindtype kt;
15716   tree type2;
15717
15718   if (type1 == signed_char_type_node || type1 == char_type_node)
15719     return unsigned_char_type_node;
15720   if (type1 == integer_type_node)
15721     return unsigned_type_node;
15722   if (type1 == short_integer_type_node)
15723     return short_unsigned_type_node;
15724   if (type1 == long_integer_type_node)
15725     return long_unsigned_type_node;
15726   if (type1 == long_long_integer_type_node)
15727     return long_long_unsigned_type_node;
15728 #if 0   /* gcc/c-* files only */
15729   if (type1 == intDI_type_node)
15730     return unsigned_intDI_type_node;
15731   if (type1 == intSI_type_node)
15732     return unsigned_intSI_type_node;
15733   if (type1 == intHI_type_node)
15734     return unsigned_intHI_type_node;
15735   if (type1 == intQI_type_node)
15736     return unsigned_intQI_type_node;
15737 #endif
15738
15739   type2 = type_for_size (TYPE_PRECISION (type1), 1);
15740   if (type2 != NULL_TREE)
15741     return type2;
15742
15743   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15744     {
15745       type2 = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15746
15747       if (type1 == type2)
15748         return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15749     }
15750
15751   return type;
15752 }
15753
15754 /* Callback routines for garbage collection.  */
15755
15756 int ggc_p = 1;
15757
15758 void
15759 lang_mark_tree (t)
15760      union tree_node *t ATTRIBUTE_UNUSED;
15761 {
15762   if (TREE_CODE (t) == IDENTIFIER_NODE)
15763     {
15764       struct lang_identifier *i = (struct lang_identifier *) t;
15765       ggc_mark_tree (IDENTIFIER_GLOBAL_VALUE (i));
15766       ggc_mark_tree (IDENTIFIER_LOCAL_VALUE (i));
15767       ggc_mark_tree (IDENTIFIER_LABEL_VALUE (i));
15768     }
15769   else if (TYPE_P (t) && TYPE_LANG_SPECIFIC (t))
15770     ggc_mark (TYPE_LANG_SPECIFIC (t));
15771 }
15772
15773 void
15774 lang_mark_false_label_stack (l)
15775      struct label_node *l;
15776 {
15777   /* Fortran doesn't use false_label_stack.  It better be NULL.  */
15778   if (l != NULL)
15779     abort();
15780 }
15781
15782 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
15783 \f
15784 #if FFECOM_GCC_INCLUDE
15785
15786 /* From gcc/cccp.c, the code to handle -I.  */
15787
15788 /* Skip leading "./" from a directory name.
15789    This may yield the empty string, which represents the current directory.  */
15790
15791 static const char *
15792 skip_redundant_dir_prefix (const char *dir)
15793 {
15794   while (dir[0] == '.' && dir[1] == '/')
15795     for (dir += 2; *dir == '/'; dir++)
15796       continue;
15797   if (dir[0] == '.' && !dir[1])
15798     dir++;
15799   return dir;
15800 }
15801
15802 /* The file_name_map structure holds a mapping of file names for a
15803    particular directory.  This mapping is read from the file named
15804    FILE_NAME_MAP_FILE in that directory.  Such a file can be used to
15805    map filenames on a file system with severe filename restrictions,
15806    such as DOS.  The format of the file name map file is just a series
15807    of lines with two tokens on each line.  The first token is the name
15808    to map, and the second token is the actual name to use.  */
15809
15810 struct file_name_map
15811 {
15812   struct file_name_map *map_next;
15813   char *map_from;
15814   char *map_to;
15815 };
15816
15817 #define FILE_NAME_MAP_FILE "header.gcc"
15818
15819 /* Current maximum length of directory names in the search path
15820    for include files.  (Altered as we get more of them.)  */
15821
15822 static int max_include_len = 0;
15823
15824 struct file_name_list
15825   {
15826     struct file_name_list *next;
15827     char *fname;
15828     /* Mapping of file names for this directory.  */
15829     struct file_name_map *name_map;
15830     /* Non-zero if name_map is valid.  */
15831     int got_name_map;
15832   };
15833
15834 static struct file_name_list *include = NULL;   /* First dir to search */
15835 static struct file_name_list *last_include = NULL;      /* Last in chain */
15836
15837 /* I/O buffer structure.
15838    The `fname' field is nonzero for source files and #include files
15839    and for the dummy text used for -D and -U.
15840    It is zero for rescanning results of macro expansion
15841    and for expanding macro arguments.  */
15842 #define INPUT_STACK_MAX 400
15843 static struct file_buf {
15844   const char *fname;
15845   /* Filename specified with #line command.  */
15846   const char *nominal_fname;
15847   /* Record where in the search path this file was found.
15848      For #include_next.  */
15849   struct file_name_list *dir;
15850   ffewhereLine line;
15851   ffewhereColumn column;
15852 } instack[INPUT_STACK_MAX];
15853
15854 static int last_error_tick = 0;    /* Incremented each time we print it.  */
15855 static int input_file_stack_tick = 0;  /* Incremented when status changes.  */
15856
15857 /* Current nesting level of input sources.
15858    `instack[indepth]' is the level currently being read.  */
15859 static int indepth = -1;
15860
15861 typedef struct file_buf FILE_BUF;
15862
15863 typedef unsigned char U_CHAR;
15864
15865 /* table to tell if char can be part of a C identifier. */
15866 U_CHAR is_idchar[256];
15867 /* table to tell if char can be first char of a c identifier. */
15868 U_CHAR is_idstart[256];
15869 /* table to tell if c is horizontal space.  */
15870 U_CHAR is_hor_space[256];
15871 /* table to tell if c is horizontal or vertical space.  */
15872 static U_CHAR is_space[256];
15873
15874 #define SKIP_WHITE_SPACE(p) do { while (is_hor_space[*p]) p++; } while (0)
15875 #define SKIP_ALL_WHITE_SPACE(p) do { while (is_space[*p]) p++; } while (0)
15876
15877 /* Nonzero means -I- has been seen,
15878    so don't look for #include "foo" the source-file directory.  */
15879 static int ignore_srcdir;
15880
15881 #ifndef INCLUDE_LEN_FUDGE
15882 #define INCLUDE_LEN_FUDGE 0
15883 #endif
15884
15885 static void append_include_chain (struct file_name_list *first,
15886                                   struct file_name_list *last);
15887 static FILE *open_include_file (char *filename,
15888                                 struct file_name_list *searchptr);
15889 static void print_containing_files (ffebadSeverity sev);
15890 static const char *skip_redundant_dir_prefix (const char *);
15891 static char *read_filename_string (int ch, FILE *f);
15892 static struct file_name_map *read_name_map (const char *dirname);
15893
15894 /* Append a chain of `struct file_name_list's
15895    to the end of the main include chain.
15896    FIRST is the beginning of the chain to append, and LAST is the end.  */
15897
15898 static void
15899 append_include_chain (first, last)
15900      struct file_name_list *first, *last;
15901 {
15902   struct file_name_list *dir;
15903
15904   if (!first || !last)
15905     return;
15906
15907   if (include == 0)
15908     include = first;
15909   else
15910     last_include->next = first;
15911
15912   for (dir = first; ; dir = dir->next) {
15913     int len = strlen (dir->fname) + INCLUDE_LEN_FUDGE;
15914     if (len > max_include_len)
15915       max_include_len = len;
15916     if (dir == last)
15917       break;
15918   }
15919
15920   last->next = NULL;
15921   last_include = last;
15922 }
15923
15924 /* Try to open include file FILENAME.  SEARCHPTR is the directory
15925    being tried from the include file search path.  This function maps
15926    filenames on file systems based on information read by
15927    read_name_map.  */
15928
15929 static FILE *
15930 open_include_file (filename, searchptr)
15931      char *filename;
15932      struct file_name_list *searchptr;
15933 {
15934   register struct file_name_map *map;
15935   register char *from;
15936   char *p, *dir;
15937
15938   if (searchptr && ! searchptr->got_name_map)
15939     {
15940       searchptr->name_map = read_name_map (searchptr->fname
15941                                            ? searchptr->fname : ".");
15942       searchptr->got_name_map = 1;
15943     }
15944
15945   /* First check the mapping for the directory we are using.  */
15946   if (searchptr && searchptr->name_map)
15947     {
15948       from = filename;
15949       if (searchptr->fname)
15950         from += strlen (searchptr->fname) + 1;
15951       for (map = searchptr->name_map; map; map = map->map_next)
15952         {
15953           if (! strcmp (map->map_from, from))
15954             {
15955               /* Found a match.  */
15956               return fopen (map->map_to, "r");
15957             }
15958         }
15959     }
15960
15961   /* Try to find a mapping file for the particular directory we are
15962      looking in.  Thus #include <sys/types.h> will look up sys/types.h
15963      in /usr/include/header.gcc and look up types.h in
15964      /usr/include/sys/header.gcc.  */
15965   p = rindex (filename, '/');
15966 #ifdef DIR_SEPARATOR
15967   if (! p) p = rindex (filename, DIR_SEPARATOR);
15968   else {
15969     char *tmp = rindex (filename, DIR_SEPARATOR);
15970     if (tmp != NULL && tmp > p) p = tmp;
15971   }
15972 #endif
15973   if (! p)
15974     p = filename;
15975   if (searchptr
15976       && searchptr->fname
15977       && strlen (searchptr->fname) == (size_t) (p - filename)
15978       && ! strncmp (searchptr->fname, filename, (int) (p - filename)))
15979     {
15980       /* FILENAME is in SEARCHPTR, which we've already checked.  */
15981       return fopen (filename, "r");
15982     }
15983
15984   if (p == filename)
15985     {
15986       from = filename;
15987       map = read_name_map (".");
15988     }
15989   else
15990     {
15991       dir = (char *) xmalloc (p - filename + 1);
15992       memcpy (dir, filename, p - filename);
15993       dir[p - filename] = '\0';
15994       from = p + 1;
15995       map = read_name_map (dir);
15996       free (dir);
15997     }
15998   for (; map; map = map->map_next)
15999     if (! strcmp (map->map_from, from))
16000       return fopen (map->map_to, "r");
16001
16002   return fopen (filename, "r");
16003 }
16004
16005 /* Print the file names and line numbers of the #include
16006    commands which led to the current file.  */
16007
16008 static void
16009 print_containing_files (ffebadSeverity sev)
16010 {
16011   FILE_BUF *ip = NULL;
16012   int i;
16013   int first = 1;
16014   const char *str1;
16015   const char *str2;
16016
16017   /* If stack of files hasn't changed since we last printed
16018      this info, don't repeat it.  */
16019   if (last_error_tick == input_file_stack_tick)
16020     return;
16021
16022   for (i = indepth; i >= 0; i--)
16023     if (instack[i].fname != NULL) {
16024       ip = &instack[i];
16025       break;
16026     }
16027
16028   /* Give up if we don't find a source file.  */
16029   if (ip == NULL)
16030     return;
16031
16032   /* Find the other, outer source files.  */
16033   for (i--; i >= 0; i--)
16034     if (instack[i].fname != NULL)
16035       {
16036         ip = &instack[i];
16037         if (first)
16038           {
16039             first = 0;
16040             str1 = "In file included";
16041           }
16042         else
16043           {
16044             str1 = "...          ...";
16045           }
16046
16047         if (i == 1)
16048           str2 = ":";
16049         else
16050           str2 = "";
16051
16052         ffebad_start_msg ("%A from %B at %0%C", sev);
16053         ffebad_here (0, ip->line, ip->column);
16054         ffebad_string (str1);
16055         ffebad_string (ip->nominal_fname);
16056         ffebad_string (str2);
16057         ffebad_finish ();
16058       }
16059
16060   /* Record we have printed the status as of this time.  */
16061   last_error_tick = input_file_stack_tick;
16062 }
16063
16064 /* Read a space delimited string of unlimited length from a stdio
16065    file.  */
16066
16067 static char *
16068 read_filename_string (ch, f)
16069      int ch;
16070      FILE *f;
16071 {
16072   char *alloc, *set;
16073   int len;
16074
16075   len = 20;
16076   set = alloc = xmalloc (len + 1);
16077   if (! is_space[ch])
16078     {
16079       *set++ = ch;
16080       while ((ch = getc (f)) != EOF && ! is_space[ch])
16081         {
16082           if (set - alloc == len)
16083             {
16084               len *= 2;
16085               alloc = xrealloc (alloc, len + 1);
16086               set = alloc + len / 2;
16087             }
16088           *set++ = ch;
16089         }
16090     }
16091   *set = '\0';
16092   ungetc (ch, f);
16093   return alloc;
16094 }
16095
16096 /* Read the file name map file for DIRNAME.  */
16097
16098 static struct file_name_map *
16099 read_name_map (dirname)
16100      const char *dirname;
16101 {
16102   /* This structure holds a linked list of file name maps, one per
16103      directory.  */
16104   struct file_name_map_list
16105     {
16106       struct file_name_map_list *map_list_next;
16107       char *map_list_name;
16108       struct file_name_map *map_list_map;
16109     };
16110   static struct file_name_map_list *map_list;
16111   register struct file_name_map_list *map_list_ptr;
16112   char *name;
16113   FILE *f;
16114   size_t dirlen;
16115   int separator_needed;
16116
16117   dirname = skip_redundant_dir_prefix (dirname);
16118
16119   for (map_list_ptr = map_list; map_list_ptr;
16120        map_list_ptr = map_list_ptr->map_list_next)
16121     if (! strcmp (map_list_ptr->map_list_name, dirname))
16122       return map_list_ptr->map_list_map;
16123
16124   map_list_ptr = ((struct file_name_map_list *)
16125                   xmalloc (sizeof (struct file_name_map_list)));
16126   map_list_ptr->map_list_name = xstrdup (dirname);
16127   map_list_ptr->map_list_map = NULL;
16128
16129   dirlen = strlen (dirname);
16130   separator_needed = dirlen != 0 && dirname[dirlen - 1] != '/';
16131   name = (char *) xmalloc (dirlen + strlen (FILE_NAME_MAP_FILE) + 2);
16132   strcpy (name, dirname);
16133   name[dirlen] = '/';
16134   strcpy (name + dirlen + separator_needed, FILE_NAME_MAP_FILE);
16135   f = fopen (name, "r");
16136   free (name);
16137   if (!f)
16138     map_list_ptr->map_list_map = NULL;
16139   else
16140     {
16141       int ch;
16142
16143       while ((ch = getc (f)) != EOF)
16144         {
16145           char *from, *to;
16146           struct file_name_map *ptr;
16147
16148           if (is_space[ch])
16149             continue;
16150           from = read_filename_string (ch, f);
16151           while ((ch = getc (f)) != EOF && is_hor_space[ch])
16152             ;
16153           to = read_filename_string (ch, f);
16154
16155           ptr = ((struct file_name_map *)
16156                  xmalloc (sizeof (struct file_name_map)));
16157           ptr->map_from = from;
16158
16159           /* Make the real filename absolute.  */
16160           if (*to == '/')
16161             ptr->map_to = to;
16162           else
16163             {
16164               ptr->map_to = xmalloc (dirlen + strlen (to) + 2);
16165               strcpy (ptr->map_to, dirname);
16166               ptr->map_to[dirlen] = '/';
16167               strcpy (ptr->map_to + dirlen + separator_needed, to);
16168               free (to);
16169             }
16170
16171           ptr->map_next = map_list_ptr->map_list_map;
16172           map_list_ptr->map_list_map = ptr;
16173
16174           while ((ch = getc (f)) != '\n')
16175             if (ch == EOF)
16176               break;
16177         }
16178       fclose (f);
16179     }
16180
16181   map_list_ptr->map_list_next = map_list;
16182   map_list = map_list_ptr;
16183
16184   return map_list_ptr->map_list_map;
16185 }
16186
16187 static void
16188 ffecom_file_ (const char *name)
16189 {
16190   FILE_BUF *fp;
16191
16192   /* Do partial setup of input buffer for the sake of generating
16193      early #line directives (when -g is in effect).  */
16194
16195   fp = &instack[++indepth];
16196   memset ((char *) fp, 0, sizeof (FILE_BUF));
16197   if (name == NULL)
16198     name = "";
16199   fp->nominal_fname = fp->fname = name;
16200 }
16201
16202 /* Initialize syntactic classifications of characters.  */
16203
16204 static void
16205 ffecom_initialize_char_syntax_ ()
16206 {
16207   register int i;
16208
16209   /*
16210    * Set up is_idchar and is_idstart tables.  These should be
16211    * faster than saying (is_alpha (c) || c == '_'), etc.
16212    * Set up these things before calling any routines tthat
16213    * refer to them.
16214    */
16215   for (i = 'a'; i <= 'z'; i++) {
16216     is_idchar[i - 'a' + 'A'] = 1;
16217     is_idchar[i] = 1;
16218     is_idstart[i - 'a' + 'A'] = 1;
16219     is_idstart[i] = 1;
16220   }
16221   for (i = '0'; i <= '9'; i++)
16222     is_idchar[i] = 1;
16223   is_idchar['_'] = 1;
16224   is_idstart['_'] = 1;
16225
16226   /* horizontal space table */
16227   is_hor_space[' '] = 1;
16228   is_hor_space['\t'] = 1;
16229   is_hor_space['\v'] = 1;
16230   is_hor_space['\f'] = 1;
16231   is_hor_space['\r'] = 1;
16232
16233   is_space[' '] = 1;
16234   is_space['\t'] = 1;
16235   is_space['\v'] = 1;
16236   is_space['\f'] = 1;
16237   is_space['\n'] = 1;
16238   is_space['\r'] = 1;
16239 }
16240
16241 static void
16242 ffecom_close_include_ (FILE *f)
16243 {
16244   fclose (f);
16245
16246   indepth--;
16247   input_file_stack_tick++;
16248
16249   ffewhere_line_kill (instack[indepth].line);
16250   ffewhere_column_kill (instack[indepth].column);
16251 }
16252
16253 static int
16254 ffecom_decode_include_option_ (char *spec)
16255 {
16256   struct file_name_list *dirtmp;
16257
16258   if (! ignore_srcdir && !strcmp (spec, "-"))
16259     ignore_srcdir = 1;
16260   else
16261     {
16262       dirtmp = (struct file_name_list *)
16263         xmalloc (sizeof (struct file_name_list));
16264       dirtmp->next = 0;         /* New one goes on the end */
16265       if (spec[0] != 0)
16266         dirtmp->fname = spec;
16267       else
16268         fatal ("Directory name must immediately follow -I option with no intervening spaces, as in `-Idir', not `-I dir'");
16269       dirtmp->got_name_map = 0;
16270       append_include_chain (dirtmp, dirtmp);
16271     }
16272   return 1;
16273 }
16274
16275 /* Open INCLUDEd file.  */
16276
16277 static FILE *
16278 ffecom_open_include_ (char *name, ffewhereLine l, ffewhereColumn c)
16279 {
16280   char *fbeg = name;
16281   size_t flen = strlen (fbeg);
16282   struct file_name_list *search_start = include; /* Chain of dirs to search */
16283   struct file_name_list dsp[1]; /* First in chain, if #include "..." */
16284   struct file_name_list *searchptr = 0;
16285   char *fname;          /* Dynamically allocated fname buffer */
16286   FILE *f;
16287   FILE_BUF *fp;
16288
16289   if (flen == 0)
16290     return NULL;
16291
16292   dsp[0].fname = NULL;
16293
16294   /* If -I- was specified, don't search current dir, only spec'd ones. */
16295   if (!ignore_srcdir)
16296     {
16297       for (fp = &instack[indepth]; fp >= instack; fp--)
16298         {
16299           int n;
16300           char *ep;
16301           const char *nam;
16302
16303           if ((nam = fp->nominal_fname) != NULL)
16304             {
16305               /* Found a named file.  Figure out dir of the file,
16306                  and put it in front of the search list.  */
16307               dsp[0].next = search_start;
16308               search_start = dsp;
16309 #ifndef VMS
16310               ep = rindex (nam, '/');
16311 #ifdef DIR_SEPARATOR
16312             if (ep == NULL) ep = rindex (nam, DIR_SEPARATOR);
16313             else {
16314               char *tmp = rindex (nam, DIR_SEPARATOR);
16315               if (tmp != NULL && tmp > ep) ep = tmp;
16316             }
16317 #endif
16318 #else                           /* VMS */
16319               ep = rindex (nam, ']');
16320               if (ep == NULL) ep = rindex (nam, '>');
16321               if (ep == NULL) ep = rindex (nam, ':');
16322               if (ep != NULL) ep++;
16323 #endif                          /* VMS */
16324               if (ep != NULL)
16325                 {
16326                   n = ep - nam;
16327                   dsp[0].fname = (char *) xmalloc (n + 1);
16328                   strncpy (dsp[0].fname, nam, n);
16329                   dsp[0].fname[n] = '\0';
16330                   if (n + INCLUDE_LEN_FUDGE > max_include_len)
16331                     max_include_len = n + INCLUDE_LEN_FUDGE;
16332                 }
16333               else
16334                 dsp[0].fname = NULL; /* Current directory */
16335               dsp[0].got_name_map = 0;
16336               break;
16337             }
16338         }
16339     }
16340
16341   /* Allocate this permanently, because it gets stored in the definitions
16342      of macros.  */
16343   fname = xmalloc (max_include_len + flen + 4);
16344   /* + 2 above for slash and terminating null.  */
16345   /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
16346      for g77 yet).  */
16347
16348   /* If specified file name is absolute, just open it.  */
16349
16350   if (*fbeg == '/'
16351 #ifdef DIR_SEPARATOR
16352       || *fbeg == DIR_SEPARATOR
16353 #endif
16354       )
16355     {
16356       strncpy (fname, (char *) fbeg, flen);
16357       fname[flen] = 0;
16358       f = open_include_file (fname, NULL_PTR);
16359     }
16360   else
16361     {
16362       f = NULL;
16363
16364       /* Search directory path, trying to open the file.
16365          Copy each filename tried into FNAME.  */
16366
16367       for (searchptr = search_start; searchptr; searchptr = searchptr->next)
16368         {
16369           if (searchptr->fname)
16370             {
16371               /* The empty string in a search path is ignored.
16372                  This makes it possible to turn off entirely
16373                  a standard piece of the list.  */
16374               if (searchptr->fname[0] == 0)
16375                 continue;
16376               strcpy (fname, skip_redundant_dir_prefix (searchptr->fname));
16377               if (fname[0] && fname[strlen (fname) - 1] != '/')
16378                 strcat (fname, "/");
16379               fname[strlen (fname) + flen] = 0;
16380             }
16381           else
16382             fname[0] = 0;
16383
16384           strncat (fname, fbeg, flen);
16385 #ifdef VMS
16386           /* Change this 1/2 Unix 1/2 VMS file specification into a
16387              full VMS file specification */
16388           if (searchptr->fname && (searchptr->fname[0] != 0))
16389             {
16390               /* Fix up the filename */
16391               hack_vms_include_specification (fname);
16392             }
16393           else
16394             {
16395               /* This is a normal VMS filespec, so use it unchanged.  */
16396               strncpy (fname, (char *) fbeg, flen);
16397               fname[flen] = 0;
16398 #if 0   /* Not for g77.  */
16399               /* if it's '#include filename', add the missing .h */
16400               if (index (fname, '.') == NULL)
16401                 strcat (fname, ".h");
16402 #endif
16403             }
16404 #endif /* VMS */
16405           f = open_include_file (fname, searchptr);
16406 #ifdef EACCES
16407           if (f == NULL && errno == EACCES)
16408             {
16409               print_containing_files (FFEBAD_severityWARNING);
16410               ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
16411                                 FFEBAD_severityWARNING);
16412               ffebad_string (fname);
16413               ffebad_here (0, l, c);
16414               ffebad_finish ();
16415             }
16416 #endif
16417           if (f != NULL)
16418             break;
16419         }
16420     }
16421
16422   if (f == NULL)
16423     {
16424       /* A file that was not found.  */
16425
16426       strncpy (fname, (char *) fbeg, flen);
16427       fname[flen] = 0;
16428       print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE));
16429       ffebad_start (FFEBAD_OPEN_INCLUDE);
16430       ffebad_here (0, l, c);
16431       ffebad_string (fname);
16432       ffebad_finish ();
16433     }
16434
16435   if (dsp[0].fname != NULL)
16436     free (dsp[0].fname);
16437
16438   if (f == NULL)
16439     return NULL;
16440
16441   if (indepth >= (INPUT_STACK_MAX - 1))
16442     {
16443       print_containing_files (FFEBAD_severityFATAL);
16444       ffebad_start_msg ("At %0, INCLUDE nesting too deep",
16445                         FFEBAD_severityFATAL);
16446       ffebad_string (fname);
16447       ffebad_here (0, l, c);
16448       ffebad_finish ();
16449       return NULL;
16450     }
16451
16452   instack[indepth].line = ffewhere_line_use (l);
16453   instack[indepth].column = ffewhere_column_use (c);
16454
16455   fp = &instack[indepth + 1];
16456   memset ((char *) fp, 0, sizeof (FILE_BUF));
16457   fp->nominal_fname = fp->fname = fname;
16458   fp->dir = searchptr;
16459
16460   indepth++;
16461   input_file_stack_tick++;
16462
16463   return f;
16464 }
16465 #endif  /* FFECOM_GCC_INCLUDE */
16466
16467 /**INDENT* (Do not reformat this comment even with -fca option.)
16468    Data-gathering files: Given the source file listed below, compiled with
16469    f2c I obtained the output file listed after that, and from the output
16470    file I derived the above code.
16471
16472 -------- (begin input file to f2c)
16473         implicit none
16474         character*10 A1,A2
16475         complex C1,C2
16476         integer I1,I2
16477         real R1,R2
16478         double precision D1,D2
16479 C
16480         call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
16481 c /
16482         call fooI(I1/I2)
16483         call fooR(R1/I1)
16484         call fooD(D1/I1)
16485         call fooC(C1/I1)
16486         call fooR(R1/R2)
16487         call fooD(R1/D1)
16488         call fooD(D1/D2)
16489         call fooD(D1/R1)
16490         call fooC(C1/C2)
16491         call fooC(C1/R1)
16492         call fooZ(C1/D1)
16493 c **
16494         call fooI(I1**I2)
16495         call fooR(R1**I1)
16496         call fooD(D1**I1)
16497         call fooC(C1**I1)
16498         call fooR(R1**R2)
16499         call fooD(R1**D1)
16500         call fooD(D1**D2)
16501         call fooD(D1**R1)
16502         call fooC(C1**C2)
16503         call fooC(C1**R1)
16504         call fooZ(C1**D1)
16505 c FFEINTRIN_impABS
16506         call fooR(ABS(R1))
16507 c FFEINTRIN_impACOS
16508         call fooR(ACOS(R1))
16509 c FFEINTRIN_impAIMAG
16510         call fooR(AIMAG(C1))
16511 c FFEINTRIN_impAINT
16512         call fooR(AINT(R1))
16513 c FFEINTRIN_impALOG
16514         call fooR(ALOG(R1))
16515 c FFEINTRIN_impALOG10
16516         call fooR(ALOG10(R1))
16517 c FFEINTRIN_impAMAX0
16518         call fooR(AMAX0(I1,I2))
16519 c FFEINTRIN_impAMAX1
16520         call fooR(AMAX1(R1,R2))
16521 c FFEINTRIN_impAMIN0
16522         call fooR(AMIN0(I1,I2))
16523 c FFEINTRIN_impAMIN1
16524         call fooR(AMIN1(R1,R2))
16525 c FFEINTRIN_impAMOD
16526         call fooR(AMOD(R1,R2))
16527 c FFEINTRIN_impANINT
16528         call fooR(ANINT(R1))
16529 c FFEINTRIN_impASIN
16530         call fooR(ASIN(R1))
16531 c FFEINTRIN_impATAN
16532         call fooR(ATAN(R1))
16533 c FFEINTRIN_impATAN2
16534         call fooR(ATAN2(R1,R2))
16535 c FFEINTRIN_impCABS
16536         call fooR(CABS(C1))
16537 c FFEINTRIN_impCCOS
16538         call fooC(CCOS(C1))
16539 c FFEINTRIN_impCEXP
16540         call fooC(CEXP(C1))
16541 c FFEINTRIN_impCHAR
16542         call fooA(CHAR(I1))
16543 c FFEINTRIN_impCLOG
16544         call fooC(CLOG(C1))
16545 c FFEINTRIN_impCONJG
16546         call fooC(CONJG(C1))
16547 c FFEINTRIN_impCOS
16548         call fooR(COS(R1))
16549 c FFEINTRIN_impCOSH
16550         call fooR(COSH(R1))
16551 c FFEINTRIN_impCSIN
16552         call fooC(CSIN(C1))
16553 c FFEINTRIN_impCSQRT
16554         call fooC(CSQRT(C1))
16555 c FFEINTRIN_impDABS
16556         call fooD(DABS(D1))
16557 c FFEINTRIN_impDACOS
16558         call fooD(DACOS(D1))
16559 c FFEINTRIN_impDASIN
16560         call fooD(DASIN(D1))
16561 c FFEINTRIN_impDATAN
16562         call fooD(DATAN(D1))
16563 c FFEINTRIN_impDATAN2
16564         call fooD(DATAN2(D1,D2))
16565 c FFEINTRIN_impDCOS
16566         call fooD(DCOS(D1))
16567 c FFEINTRIN_impDCOSH
16568         call fooD(DCOSH(D1))
16569 c FFEINTRIN_impDDIM
16570         call fooD(DDIM(D1,D2))
16571 c FFEINTRIN_impDEXP
16572         call fooD(DEXP(D1))
16573 c FFEINTRIN_impDIM
16574         call fooR(DIM(R1,R2))
16575 c FFEINTRIN_impDINT
16576         call fooD(DINT(D1))
16577 c FFEINTRIN_impDLOG
16578         call fooD(DLOG(D1))
16579 c FFEINTRIN_impDLOG10
16580         call fooD(DLOG10(D1))
16581 c FFEINTRIN_impDMAX1
16582         call fooD(DMAX1(D1,D2))
16583 c FFEINTRIN_impDMIN1
16584         call fooD(DMIN1(D1,D2))
16585 c FFEINTRIN_impDMOD
16586         call fooD(DMOD(D1,D2))
16587 c FFEINTRIN_impDNINT
16588         call fooD(DNINT(D1))
16589 c FFEINTRIN_impDPROD
16590         call fooD(DPROD(R1,R2))
16591 c FFEINTRIN_impDSIGN
16592         call fooD(DSIGN(D1,D2))
16593 c FFEINTRIN_impDSIN
16594         call fooD(DSIN(D1))
16595 c FFEINTRIN_impDSINH
16596         call fooD(DSINH(D1))
16597 c FFEINTRIN_impDSQRT
16598         call fooD(DSQRT(D1))
16599 c FFEINTRIN_impDTAN
16600         call fooD(DTAN(D1))
16601 c FFEINTRIN_impDTANH
16602         call fooD(DTANH(D1))
16603 c FFEINTRIN_impEXP
16604         call fooR(EXP(R1))
16605 c FFEINTRIN_impIABS
16606         call fooI(IABS(I1))
16607 c FFEINTRIN_impICHAR
16608         call fooI(ICHAR(A1))
16609 c FFEINTRIN_impIDIM
16610         call fooI(IDIM(I1,I2))
16611 c FFEINTRIN_impIDNINT
16612         call fooI(IDNINT(D1))
16613 c FFEINTRIN_impINDEX
16614         call fooI(INDEX(A1,A2))
16615 c FFEINTRIN_impISIGN
16616         call fooI(ISIGN(I1,I2))
16617 c FFEINTRIN_impLEN
16618         call fooI(LEN(A1))
16619 c FFEINTRIN_impLGE
16620         call fooL(LGE(A1,A2))
16621 c FFEINTRIN_impLGT
16622         call fooL(LGT(A1,A2))
16623 c FFEINTRIN_impLLE
16624         call fooL(LLE(A1,A2))
16625 c FFEINTRIN_impLLT
16626         call fooL(LLT(A1,A2))
16627 c FFEINTRIN_impMAX0
16628         call fooI(MAX0(I1,I2))
16629 c FFEINTRIN_impMAX1
16630         call fooI(MAX1(R1,R2))
16631 c FFEINTRIN_impMIN0
16632         call fooI(MIN0(I1,I2))
16633 c FFEINTRIN_impMIN1
16634         call fooI(MIN1(R1,R2))
16635 c FFEINTRIN_impMOD
16636         call fooI(MOD(I1,I2))
16637 c FFEINTRIN_impNINT
16638         call fooI(NINT(R1))
16639 c FFEINTRIN_impSIGN
16640         call fooR(SIGN(R1,R2))
16641 c FFEINTRIN_impSIN
16642         call fooR(SIN(R1))
16643 c FFEINTRIN_impSINH
16644         call fooR(SINH(R1))
16645 c FFEINTRIN_impSQRT
16646         call fooR(SQRT(R1))
16647 c FFEINTRIN_impTAN
16648         call fooR(TAN(R1))
16649 c FFEINTRIN_impTANH
16650         call fooR(TANH(R1))
16651 c FFEINTRIN_imp_CMPLX_C
16652         call fooC(cmplx(C1,C2))
16653 c FFEINTRIN_imp_CMPLX_D
16654         call fooZ(cmplx(D1,D2))
16655 c FFEINTRIN_imp_CMPLX_I
16656         call fooC(cmplx(I1,I2))
16657 c FFEINTRIN_imp_CMPLX_R
16658         call fooC(cmplx(R1,R2))
16659 c FFEINTRIN_imp_DBLE_C
16660         call fooD(dble(C1))
16661 c FFEINTRIN_imp_DBLE_D
16662         call fooD(dble(D1))
16663 c FFEINTRIN_imp_DBLE_I
16664         call fooD(dble(I1))
16665 c FFEINTRIN_imp_DBLE_R
16666         call fooD(dble(R1))
16667 c FFEINTRIN_imp_INT_C
16668         call fooI(int(C1))
16669 c FFEINTRIN_imp_INT_D
16670         call fooI(int(D1))
16671 c FFEINTRIN_imp_INT_I
16672         call fooI(int(I1))
16673 c FFEINTRIN_imp_INT_R
16674         call fooI(int(R1))
16675 c FFEINTRIN_imp_REAL_C
16676         call fooR(real(C1))
16677 c FFEINTRIN_imp_REAL_D
16678         call fooR(real(D1))
16679 c FFEINTRIN_imp_REAL_I
16680         call fooR(real(I1))
16681 c FFEINTRIN_imp_REAL_R
16682         call fooR(real(R1))
16683 c
16684 c FFEINTRIN_imp_INT_D:
16685 c
16686 c FFEINTRIN_specIDINT
16687         call fooI(IDINT(D1))
16688 c
16689 c FFEINTRIN_imp_INT_R:
16690 c
16691 c FFEINTRIN_specIFIX
16692         call fooI(IFIX(R1))
16693 c FFEINTRIN_specINT
16694         call fooI(INT(R1))
16695 c
16696 c FFEINTRIN_imp_REAL_D:
16697 c
16698 c FFEINTRIN_specSNGL
16699         call fooR(SNGL(D1))
16700 c
16701 c FFEINTRIN_imp_REAL_I:
16702 c
16703 c FFEINTRIN_specFLOAT
16704         call fooR(FLOAT(I1))
16705 c FFEINTRIN_specREAL
16706         call fooR(REAL(I1))
16707 c
16708         end
16709 -------- (end input file to f2c)
16710
16711 -------- (begin output from providing above input file as input to:
16712 --------  `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
16713 --------     -e "s:^#.*$::g"')
16714
16715 //  -- translated by f2c (version 19950223).
16716    You must link the resulting object file with the libraries:
16717         -lf2c -lm   (in that order)
16718 //
16719
16720
16721 // f2c.h  --  Standard Fortran to C header file //
16722
16723 ///  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
16724
16725         - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
16726
16727
16728
16729
16730 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
16731 // we assume short, float are OK //
16732 typedef long int // long int // integer;
16733 typedef char *address;
16734 typedef short int shortint;
16735 typedef float real;
16736 typedef double doublereal;
16737 typedef struct { real r, i; } complex;
16738 typedef struct { doublereal r, i; } doublecomplex;
16739 typedef long int // long int // logical;
16740 typedef short int shortlogical;
16741 typedef char logical1;
16742 typedef char integer1;
16743 // typedef long long longint; // // system-dependent //
16744
16745
16746
16747
16748 // Extern is for use with -E //
16749
16750
16751
16752
16753 // I/O stuff //
16754
16755
16756
16757
16758
16759
16760
16761
16762 typedef long int // int or long int // flag;
16763 typedef long int // int or long int // ftnlen;
16764 typedef long int // int or long int // ftnint;
16765
16766
16767 //external read, write//
16768 typedef struct
16769 {       flag cierr;
16770         ftnint ciunit;
16771         flag ciend;
16772         char *cifmt;
16773         ftnint cirec;
16774 } cilist;
16775
16776 //internal read, write//
16777 typedef struct
16778 {       flag icierr;
16779         char *iciunit;
16780         flag iciend;
16781         char *icifmt;
16782         ftnint icirlen;
16783         ftnint icirnum;
16784 } icilist;
16785
16786 //open//
16787 typedef struct
16788 {       flag oerr;
16789         ftnint ounit;
16790         char *ofnm;
16791         ftnlen ofnmlen;
16792         char *osta;
16793         char *oacc;
16794         char *ofm;
16795         ftnint orl;
16796         char *oblnk;
16797 } olist;
16798
16799 //close//
16800 typedef struct
16801 {       flag cerr;
16802         ftnint cunit;
16803         char *csta;
16804 } cllist;
16805
16806 //rewind, backspace, endfile//
16807 typedef struct
16808 {       flag aerr;
16809         ftnint aunit;
16810 } alist;
16811
16812 // inquire //
16813 typedef struct
16814 {       flag inerr;
16815         ftnint inunit;
16816         char *infile;
16817         ftnlen infilen;
16818         ftnint  *inex;  //parameters in standard's order//
16819         ftnint  *inopen;
16820         ftnint  *innum;
16821         ftnint  *innamed;
16822         char    *inname;
16823         ftnlen  innamlen;
16824         char    *inacc;
16825         ftnlen  inacclen;
16826         char    *inseq;
16827         ftnlen  inseqlen;
16828         char    *indir;
16829         ftnlen  indirlen;
16830         char    *infmt;
16831         ftnlen  infmtlen;
16832         char    *inform;
16833         ftnint  informlen;
16834         char    *inunf;
16835         ftnlen  inunflen;
16836         ftnint  *inrecl;
16837         ftnint  *innrec;
16838         char    *inblank;
16839         ftnlen  inblanklen;
16840 } inlist;
16841
16842
16843
16844 union Multitype {       // for multiple entry points //
16845         integer1 g;
16846         shortint h;
16847         integer i;
16848         // longint j; //
16849         real r;
16850         doublereal d;
16851         complex c;
16852         doublecomplex z;
16853         };
16854
16855 typedef union Multitype Multitype;
16856
16857 typedef long Long;      // No longer used; formerly in Namelist //
16858
16859 struct Vardesc {        // for Namelist //
16860         char *name;
16861         char *addr;
16862         ftnlen *dims;
16863         int  type;
16864         };
16865 typedef struct Vardesc Vardesc;
16866
16867 struct Namelist {
16868         char *name;
16869         Vardesc **vars;
16870         int nvars;
16871         };
16872 typedef struct Namelist Namelist;
16873
16874
16875
16876
16877
16878
16879
16880
16881 // procedure parameter types for -A and -C++ //
16882
16883
16884
16885
16886 typedef int // Unknown procedure type // (*U_fp)();
16887 typedef shortint (*J_fp)();
16888 typedef integer (*I_fp)();
16889 typedef real (*R_fp)();
16890 typedef doublereal (*D_fp)(), (*E_fp)();
16891 typedef // Complex // void  (*C_fp)();
16892 typedef // Double Complex // void  (*Z_fp)();
16893 typedef logical (*L_fp)();
16894 typedef shortlogical (*K_fp)();
16895 typedef // Character // void  (*H_fp)();
16896 typedef // Subroutine // int (*S_fp)();
16897
16898 // E_fp is for real functions when -R is not specified //
16899 typedef void  C_f;      // complex function //
16900 typedef void  H_f;      // character function //
16901 typedef void  Z_f;      // double complex function //
16902 typedef doublereal E_f; // real function with -R not specified //
16903
16904 // undef any lower-case symbols that your C compiler predefines, e.g.: //
16905
16906
16907 // (No such symbols should be defined in a strict ANSI C compiler.
16908    We can avoid trouble with f2c-translated code by using
16909    gcc -ansi [-traditional].) //
16910
16911
16912
16913
16914
16915
16916
16917
16918
16919
16920
16921
16922
16923
16924
16925
16926
16927
16928
16929
16930
16931
16932
16933 // Main program // MAIN__()
16934 {
16935     // System generated locals //
16936     integer i__1;
16937     real r__1, r__2;
16938     doublereal d__1, d__2;
16939     complex q__1;
16940     doublecomplex z__1, z__2, z__3;
16941     logical L__1;
16942     char ch__1[1];
16943
16944     // Builtin functions //
16945     void c_div();
16946     integer pow_ii();
16947     double pow_ri(), pow_di();
16948     void pow_ci();
16949     double pow_dd();
16950     void pow_zz();
16951     double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
16952             asin(), atan(), atan2(), c_abs();
16953     void c_cos(), c_exp(), c_log(), r_cnjg();
16954     double cos(), cosh();
16955     void c_sin(), c_sqrt();
16956     double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
16957             d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
16958     integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
16959     logical l_ge(), l_gt(), l_le(), l_lt();
16960     integer i_nint();
16961     double r_sign();
16962
16963     // Local variables //
16964     extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
16965             fool_(), fooz_(), getem_();
16966     static char a1[10], a2[10];
16967     static complex c1, c2;
16968     static doublereal d1, d2;
16969     static integer i1, i2;
16970     static real r1, r2;
16971
16972
16973     getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
16974 // / //
16975     i__1 = i1 / i2;
16976     fooi_(&i__1);
16977     r__1 = r1 / i1;
16978     foor_(&r__1);
16979     d__1 = d1 / i1;
16980     food_(&d__1);
16981     d__1 = (doublereal) i1;
16982     q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
16983     fooc_(&q__1);
16984     r__1 = r1 / r2;
16985     foor_(&r__1);
16986     d__1 = r1 / d1;
16987     food_(&d__1);
16988     d__1 = d1 / d2;
16989     food_(&d__1);
16990     d__1 = d1 / r1;
16991     food_(&d__1);
16992     c_div(&q__1, &c1, &c2);
16993     fooc_(&q__1);
16994     q__1.r = c1.r / r1, q__1.i = c1.i / r1;
16995     fooc_(&q__1);
16996     z__1.r = c1.r / d1, z__1.i = c1.i / d1;
16997     fooz_(&z__1);
16998 // ** //
16999     i__1 = pow_ii(&i1, &i2);
17000     fooi_(&i__1);
17001     r__1 = pow_ri(&r1, &i1);
17002     foor_(&r__1);
17003     d__1 = pow_di(&d1, &i1);
17004     food_(&d__1);
17005     pow_ci(&q__1, &c1, &i1);
17006     fooc_(&q__1);
17007     d__1 = (doublereal) r1;
17008     d__2 = (doublereal) r2;
17009     r__1 = pow_dd(&d__1, &d__2);
17010     foor_(&r__1);
17011     d__2 = (doublereal) r1;
17012     d__1 = pow_dd(&d__2, &d1);
17013     food_(&d__1);
17014     d__1 = pow_dd(&d1, &d2);
17015     food_(&d__1);
17016     d__2 = (doublereal) r1;
17017     d__1 = pow_dd(&d1, &d__2);
17018     food_(&d__1);
17019     z__2.r = c1.r, z__2.i = c1.i;
17020     z__3.r = c2.r, z__3.i = c2.i;
17021     pow_zz(&z__1, &z__2, &z__3);
17022     q__1.r = z__1.r, q__1.i = z__1.i;
17023     fooc_(&q__1);
17024     z__2.r = c1.r, z__2.i = c1.i;
17025     z__3.r = r1, z__3.i = 0.;
17026     pow_zz(&z__1, &z__2, &z__3);
17027     q__1.r = z__1.r, q__1.i = z__1.i;
17028     fooc_(&q__1);
17029     z__2.r = c1.r, z__2.i = c1.i;
17030     z__3.r = d1, z__3.i = 0.;
17031     pow_zz(&z__1, &z__2, &z__3);
17032     fooz_(&z__1);
17033 // FFEINTRIN_impABS //
17034     r__1 = (doublereal)((  r1  ) >= 0 ? (  r1  ) : -(  r1  ))  ;
17035     foor_(&r__1);
17036 // FFEINTRIN_impACOS //
17037     r__1 = acos(r1);
17038     foor_(&r__1);
17039 // FFEINTRIN_impAIMAG //
17040     r__1 = r_imag(&c1);
17041     foor_(&r__1);
17042 // FFEINTRIN_impAINT //
17043     r__1 = r_int(&r1);
17044     foor_(&r__1);
17045 // FFEINTRIN_impALOG //
17046     r__1 = log(r1);
17047     foor_(&r__1);
17048 // FFEINTRIN_impALOG10 //
17049     r__1 = r_lg10(&r1);
17050     foor_(&r__1);
17051 // FFEINTRIN_impAMAX0 //
17052     r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
17053     foor_(&r__1);
17054 // FFEINTRIN_impAMAX1 //
17055     r__1 = (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
17056     foor_(&r__1);
17057 // FFEINTRIN_impAMIN0 //
17058     r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
17059     foor_(&r__1);
17060 // FFEINTRIN_impAMIN1 //
17061     r__1 = (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
17062     foor_(&r__1);
17063 // FFEINTRIN_impAMOD //
17064     r__1 = r_mod(&r1, &r2);
17065     foor_(&r__1);
17066 // FFEINTRIN_impANINT //
17067     r__1 = r_nint(&r1);
17068     foor_(&r__1);
17069 // FFEINTRIN_impASIN //
17070     r__1 = asin(r1);
17071     foor_(&r__1);
17072 // FFEINTRIN_impATAN //
17073     r__1 = atan(r1);
17074     foor_(&r__1);
17075 // FFEINTRIN_impATAN2 //
17076     r__1 = atan2(r1, r2);
17077     foor_(&r__1);
17078 // FFEINTRIN_impCABS //
17079     r__1 = c_abs(&c1);
17080     foor_(&r__1);
17081 // FFEINTRIN_impCCOS //
17082     c_cos(&q__1, &c1);
17083     fooc_(&q__1);
17084 // FFEINTRIN_impCEXP //
17085     c_exp(&q__1, &c1);
17086     fooc_(&q__1);
17087 // FFEINTRIN_impCHAR //
17088     *(unsigned char *)&ch__1[0] = i1;
17089     fooa_(ch__1, 1L);
17090 // FFEINTRIN_impCLOG //
17091     c_log(&q__1, &c1);
17092     fooc_(&q__1);
17093 // FFEINTRIN_impCONJG //
17094     r_cnjg(&q__1, &c1);
17095     fooc_(&q__1);
17096 // FFEINTRIN_impCOS //
17097     r__1 = cos(r1);
17098     foor_(&r__1);
17099 // FFEINTRIN_impCOSH //
17100     r__1 = cosh(r1);
17101     foor_(&r__1);
17102 // FFEINTRIN_impCSIN //
17103     c_sin(&q__1, &c1);
17104     fooc_(&q__1);
17105 // FFEINTRIN_impCSQRT //
17106     c_sqrt(&q__1, &c1);
17107     fooc_(&q__1);
17108 // FFEINTRIN_impDABS //
17109     d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
17110     food_(&d__1);
17111 // FFEINTRIN_impDACOS //
17112     d__1 = acos(d1);
17113     food_(&d__1);
17114 // FFEINTRIN_impDASIN //
17115     d__1 = asin(d1);
17116     food_(&d__1);
17117 // FFEINTRIN_impDATAN //
17118     d__1 = atan(d1);
17119     food_(&d__1);
17120 // FFEINTRIN_impDATAN2 //
17121     d__1 = atan2(d1, d2);
17122     food_(&d__1);
17123 // FFEINTRIN_impDCOS //
17124     d__1 = cos(d1);
17125     food_(&d__1);
17126 // FFEINTRIN_impDCOSH //
17127     d__1 = cosh(d1);
17128     food_(&d__1);
17129 // FFEINTRIN_impDDIM //
17130     d__1 = d_dim(&d1, &d2);
17131     food_(&d__1);
17132 // FFEINTRIN_impDEXP //
17133     d__1 = exp(d1);
17134     food_(&d__1);
17135 // FFEINTRIN_impDIM //
17136     r__1 = r_dim(&r1, &r2);
17137     foor_(&r__1);
17138 // FFEINTRIN_impDINT //
17139     d__1 = d_int(&d1);
17140     food_(&d__1);
17141 // FFEINTRIN_impDLOG //
17142     d__1 = log(d1);
17143     food_(&d__1);
17144 // FFEINTRIN_impDLOG10 //
17145     d__1 = d_lg10(&d1);
17146     food_(&d__1);
17147 // FFEINTRIN_impDMAX1 //
17148     d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
17149     food_(&d__1);
17150 // FFEINTRIN_impDMIN1 //
17151     d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
17152     food_(&d__1);
17153 // FFEINTRIN_impDMOD //
17154     d__1 = d_mod(&d1, &d2);
17155     food_(&d__1);
17156 // FFEINTRIN_impDNINT //
17157     d__1 = d_nint(&d1);
17158     food_(&d__1);
17159 // FFEINTRIN_impDPROD //
17160     d__1 = (doublereal) r1 * r2;
17161     food_(&d__1);
17162 // FFEINTRIN_impDSIGN //
17163     d__1 = d_sign(&d1, &d2);
17164     food_(&d__1);
17165 // FFEINTRIN_impDSIN //
17166     d__1 = sin(d1);
17167     food_(&d__1);
17168 // FFEINTRIN_impDSINH //
17169     d__1 = sinh(d1);
17170     food_(&d__1);
17171 // FFEINTRIN_impDSQRT //
17172     d__1 = sqrt(d1);
17173     food_(&d__1);
17174 // FFEINTRIN_impDTAN //
17175     d__1 = tan(d1);
17176     food_(&d__1);
17177 // FFEINTRIN_impDTANH //
17178     d__1 = tanh(d1);
17179     food_(&d__1);
17180 // FFEINTRIN_impEXP //
17181     r__1 = exp(r1);
17182     foor_(&r__1);
17183 // FFEINTRIN_impIABS //
17184     i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
17185     fooi_(&i__1);
17186 // FFEINTRIN_impICHAR //
17187     i__1 = *(unsigned char *)a1;
17188     fooi_(&i__1);
17189 // FFEINTRIN_impIDIM //
17190     i__1 = i_dim(&i1, &i2);
17191     fooi_(&i__1);
17192 // FFEINTRIN_impIDNINT //
17193     i__1 = i_dnnt(&d1);
17194     fooi_(&i__1);
17195 // FFEINTRIN_impINDEX //
17196     i__1 = i_indx(a1, a2, 10L, 10L);
17197     fooi_(&i__1);
17198 // FFEINTRIN_impISIGN //
17199     i__1 = i_sign(&i1, &i2);
17200     fooi_(&i__1);
17201 // FFEINTRIN_impLEN //
17202     i__1 = i_len(a1, 10L);
17203     fooi_(&i__1);
17204 // FFEINTRIN_impLGE //
17205     L__1 = l_ge(a1, a2, 10L, 10L);
17206     fool_(&L__1);
17207 // FFEINTRIN_impLGT //
17208     L__1 = l_gt(a1, a2, 10L, 10L);
17209     fool_(&L__1);
17210 // FFEINTRIN_impLLE //
17211     L__1 = l_le(a1, a2, 10L, 10L);
17212     fool_(&L__1);
17213 // FFEINTRIN_impLLT //
17214     L__1 = l_lt(a1, a2, 10L, 10L);
17215     fool_(&L__1);
17216 // FFEINTRIN_impMAX0 //
17217     i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
17218     fooi_(&i__1);
17219 // FFEINTRIN_impMAX1 //
17220     i__1 = (integer) (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
17221     fooi_(&i__1);
17222 // FFEINTRIN_impMIN0 //
17223     i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
17224     fooi_(&i__1);
17225 // FFEINTRIN_impMIN1 //
17226     i__1 = (integer) (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
17227     fooi_(&i__1);
17228 // FFEINTRIN_impMOD //
17229     i__1 = i1 % i2;
17230     fooi_(&i__1);
17231 // FFEINTRIN_impNINT //
17232     i__1 = i_nint(&r1);
17233     fooi_(&i__1);
17234 // FFEINTRIN_impSIGN //
17235     r__1 = r_sign(&r1, &r2);
17236     foor_(&r__1);
17237 // FFEINTRIN_impSIN //
17238     r__1 = sin(r1);
17239     foor_(&r__1);
17240 // FFEINTRIN_impSINH //
17241     r__1 = sinh(r1);
17242     foor_(&r__1);
17243 // FFEINTRIN_impSQRT //
17244     r__1 = sqrt(r1);
17245     foor_(&r__1);
17246 // FFEINTRIN_impTAN //
17247     r__1 = tan(r1);
17248     foor_(&r__1);
17249 // FFEINTRIN_impTANH //
17250     r__1 = tanh(r1);
17251     foor_(&r__1);
17252 // FFEINTRIN_imp_CMPLX_C //
17253     r__1 = c1.r;
17254     r__2 = c2.r;
17255     q__1.r = r__1, q__1.i = r__2;
17256     fooc_(&q__1);
17257 // FFEINTRIN_imp_CMPLX_D //
17258     z__1.r = d1, z__1.i = d2;
17259     fooz_(&z__1);
17260 // FFEINTRIN_imp_CMPLX_I //
17261     r__1 = (real) i1;
17262     r__2 = (real) i2;
17263     q__1.r = r__1, q__1.i = r__2;
17264     fooc_(&q__1);
17265 // FFEINTRIN_imp_CMPLX_R //
17266     q__1.r = r1, q__1.i = r2;
17267     fooc_(&q__1);
17268 // FFEINTRIN_imp_DBLE_C //
17269     d__1 = (doublereal) c1.r;
17270     food_(&d__1);
17271 // FFEINTRIN_imp_DBLE_D //
17272     d__1 = d1;
17273     food_(&d__1);
17274 // FFEINTRIN_imp_DBLE_I //
17275     d__1 = (doublereal) i1;
17276     food_(&d__1);
17277 // FFEINTRIN_imp_DBLE_R //
17278     d__1 = (doublereal) r1;
17279     food_(&d__1);
17280 // FFEINTRIN_imp_INT_C //
17281     i__1 = (integer) c1.r;
17282     fooi_(&i__1);
17283 // FFEINTRIN_imp_INT_D //
17284     i__1 = (integer) d1;
17285     fooi_(&i__1);
17286 // FFEINTRIN_imp_INT_I //
17287     i__1 = i1;
17288     fooi_(&i__1);
17289 // FFEINTRIN_imp_INT_R //
17290     i__1 = (integer) r1;
17291     fooi_(&i__1);
17292 // FFEINTRIN_imp_REAL_C //
17293     r__1 = c1.r;
17294     foor_(&r__1);
17295 // FFEINTRIN_imp_REAL_D //
17296     r__1 = (real) d1;
17297     foor_(&r__1);
17298 // FFEINTRIN_imp_REAL_I //
17299     r__1 = (real) i1;
17300     foor_(&r__1);
17301 // FFEINTRIN_imp_REAL_R //
17302     r__1 = r1;
17303     foor_(&r__1);
17304
17305 // FFEINTRIN_imp_INT_D: //
17306
17307 // FFEINTRIN_specIDINT //
17308     i__1 = (integer) d1;
17309     fooi_(&i__1);
17310
17311 // FFEINTRIN_imp_INT_R: //
17312
17313 // FFEINTRIN_specIFIX //
17314     i__1 = (integer) r1;
17315     fooi_(&i__1);
17316 // FFEINTRIN_specINT //
17317     i__1 = (integer) r1;
17318     fooi_(&i__1);
17319
17320 // FFEINTRIN_imp_REAL_D: //
17321
17322 // FFEINTRIN_specSNGL //
17323     r__1 = (real) d1;
17324     foor_(&r__1);
17325
17326 // FFEINTRIN_imp_REAL_I: //
17327
17328 // FFEINTRIN_specFLOAT //
17329     r__1 = (real) i1;
17330     foor_(&r__1);
17331 // FFEINTRIN_specREAL //
17332     r__1 = (real) i1;
17333     foor_(&r__1);
17334
17335 } // MAIN__ //
17336
17337 -------- (end output file from f2c)
17338
17339 */