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    if (is_nested) push_f_function_context ();
  58    start_function (get_identifier ("function_name"), function_type,
  59                    is_nested, is_public);
  60    // for each arg, build PARM_DECL and call push_parm_decl (decl) with it;
  61    store_parm_decls (is_main_program);
  62    ffecom_start_compstmt ();
  63    // for stmts and decls inside function, do appropriate things;
  64    ffecom_end_compstmt ();
  65    finish_function (is_nested);
  66    if (is_nested) pop_f_function_context ();
  67
  68    Everything Else:
  69    tree d;
  70    tree init;
  71    // fill in external, public, static, &c for decl, and
  72    // set DECL_INITIAL to error_mark_node if going to initialize
  73    // set is_top_level TRUE only if not at top level and decl
  74    // must go in top level (i.e. not within current function decl context)
  75    d = start_decl (decl, is_top_level);
  76    init = ...;  // if have initializer
  77    finish_decl (d, init, is_top_level);
  78
  79 */
  80
  81 /* Include files. */
  82
  83 #include "proj.h"
  84 #if FFECOM_targetCURRENT == FFECOM_targetGCC
  85 #include "flags.h"
  86 #include "rtl.h"
  87 #include "toplev.h"
  88 #include "tree.h"
  89 #include "output.h"  /* Must follow tree.h so TREE_CODE is defined! */
  90 #include "convert.h"
  91 #include "ggc.h"
  92 #include "defaults.h"
  93 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
  94
  95 #define FFECOM_GCC_INCLUDE 1    /* Enable -I. */
  96
  97 /* BEGIN stuff from gcc/cccp.c.  */
  98
  99 /* The following symbols should be autoconfigured:
 100         HAVE_FCNTL_H
 101         HAVE_STDLIB_H
 102         HAVE_SYS_TIME_H
 103         HAVE_UNISTD_H
 104         STDC_HEADERS
 105         TIME_WITH_SYS_TIME
 106    In the mean time, we'll get by with approximations based
 107    on existing GCC configuration symbols.  */
 108
 109 #ifdef POSIX
 110 # ifndef HAVE_STDLIB_H
 111 # define HAVE_STDLIB_H 1
 112 # endif
 113 # ifndef HAVE_UNISTD_H
 114 # define HAVE_UNISTD_H 1
 115 # endif
 116 # ifndef STDC_HEADERS
 117 # define STDC_HEADERS 1
 118 # endif
 119 #endif /* defined (POSIX) */
 120
 121 #if defined (POSIX) || (defined (USG) && !defined (VMS))
 122 # ifndef HAVE_FCNTL_H
 123 # define HAVE_FCNTL_H 1
 124 # endif
 125 #endif
 126
 127 #ifndef RLIMIT_STACK
 128 # include <time.h>
 129 #else
 130 # if TIME_WITH_SYS_TIME
 131 #  include <sys/time.h>
 132 #  include <time.h>
 133 # else
 134 #  if HAVE_SYS_TIME_H
 135 #   include <sys/time.h>
 136 #  else
 137 #   include <time.h>
 138 #  endif
 139 # endif
 140 # include <sys/resource.h>
 141 #endif
 142
 143 #if HAVE_FCNTL_H
 144 # include <fcntl.h>
 145 #endif
 146
 147 /* This defines "errno" properly for VMS, and gives us EACCES. */
 148 #include <errno.h>
 149
 150 #if HAVE_STDLIB_H
 151 # include <stdlib.h>
 152 #else
 153 char *getenv ();
 154 #endif
 155
 156 #if HAVE_UNISTD_H
 157 # include <unistd.h>
 158 #endif
 159
 160 /* VMS-specific definitions */
 161 #ifdef VMS
 162 #include <descrip.h>
 163 #define O_RDONLY        0       /* Open arg for Read/Only  */
 164 #define O_WRONLY        1       /* Open arg for Write/Only */
 165 #define read(fd,buf,size)       VMS_read (fd,buf,size)
 166 #define write(fd,buf,size)      VMS_write (fd,buf,size)
 167 #define open(fname,mode,prot)   VMS_open (fname,mode,prot)
 168 #define fopen(fname,mode)       VMS_fopen (fname,mode)
 169 #define freopen(fname,mode,ofile) VMS_freopen (fname,mode,ofile)
 170 #define strncat(dst,src,cnt) VMS_strncat (dst,src,cnt)
 171 #define fstat(fd,stbuf)         VMS_fstat (fd,stbuf)
 172 static int VMS_fstat (), VMS_stat ();
 173 static char * VMS_strncat ();
 174 static int VMS_read ();
 175 static int VMS_write ();
 176 static int VMS_open ();
 177 static FILE * VMS_fopen ();
 178 static FILE * VMS_freopen ();
 179 static void hack_vms_include_specification ();
 180 typedef struct { unsigned :16, :16, :16; } vms_ino_t;
 181 #define ino_t vms_ino_t
 182 #define INCLUDE_LEN_FUDGE 10    /* leave room for VMS syntax conversion */
 183 #endif /* VMS */
 184
 185 #ifndef O_RDONLY
 186 #define O_RDONLY 0
 187 #endif
 188
 189 /* END stuff from gcc/cccp.c.  */
 190
 191 #define FFECOM_DETERMINE_TYPES 1 /* for com.h */
 192 #include "com.h"
 193 #include "bad.h"
 194 #include "bld.h"
 195 #include "equiv.h"
 196 #include "expr.h"
 197 #include "implic.h"
 198 #include "info.h"
 199 #include "malloc.h"
 200 #include "src.h"
 201 #include "st.h"
 202 #include "storag.h"
 203 #include "symbol.h"
 204 #include "target.h"
 205 #include "top.h"
 206 #include "type.h"
 207
 208 /* Externals defined here.  */
 209
 210 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 211
 212 /* ~~gcc/tree.h *should* declare this, because toplev.c and dwarfout.c
 213    reference it.  */
 214
 215 const char * const language_string = "GNU F77";
 216
 217 /* Stream for reading from the input file.  */
 218 FILE *finput;
 219
 220 /* These definitions parallel those in c-decl.c so that code from that
 221    module can be used pretty much as is.  Much of these defs aren't
 222    otherwise used, i.e. by g77 code per se, except some of them are used
 223    to build some of them that are.  The ones that are global (i.e. not
 224    "static") are those that ste.c and such might use (directly
 225    or by using com macros that reference them in their definitions).  */
 226
 227 tree string_type_node;
 228
 229 /* The rest of these are inventions for g77, though there might be
 230    similar things in the C front end.  As they are found, these
 231    inventions should be renamed to be canonical.  Note that only
 232    the ones currently required to be global are so.  */
 233
 234 static tree ffecom_tree_fun_type_void;
 235
 236 tree ffecom_integer_type_node;  /* Abbrev for _tree_type[blah][blah]. */
 237 tree ffecom_integer_zero_node;  /* Like *_*_* with g77's integer type. */
 238 tree ffecom_integer_one_node;   /* " */
 239 tree ffecom_tree_type[FFEINFO_basictype][FFEINFO_kindtype];
 240
 241 /* _fun_type things are the f2c-specific versions.  For -fno-f2c,
 242    just use build_function_type and build_pointer_type on the
 243    appropriate _tree_type array element.  */
 244
 245 static tree ffecom_tree_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
 246 static tree ffecom_tree_ptr_to_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
 247 static tree ffecom_tree_subr_type;
 248 static tree ffecom_tree_ptr_to_subr_type;
 249 static tree ffecom_tree_blockdata_type;
 250
 251 static tree ffecom_tree_xargc_;
 252
 253 ffecomSymbol ffecom_symbol_null_
 254 =
 255 {
 256   NULL_TREE,
 257   NULL_TREE,
 258   NULL_TREE,
 259   NULL_TREE,
 260   false
 261 };
 262 ffeinfoKindtype ffecom_pointer_kind_ = FFEINFO_basictypeNONE;
 263 ffeinfoKindtype ffecom_label_kind_ = FFEINFO_basictypeNONE;
 264
 265 int ffecom_f2c_typecode_[FFEINFO_basictype][FFEINFO_kindtype];
 266 tree ffecom_f2c_integer_type_node;
 267 tree ffecom_f2c_ptr_to_integer_type_node;
 268 tree ffecom_f2c_address_type_node;
 269 tree ffecom_f2c_real_type_node;
 270 tree ffecom_f2c_ptr_to_real_type_node;
 271 tree ffecom_f2c_doublereal_type_node;
 272 tree ffecom_f2c_complex_type_node;
 273 tree ffecom_f2c_doublecomplex_type_node;
 274 tree ffecom_f2c_longint_type_node;
 275 tree ffecom_f2c_logical_type_node;
 276 tree ffecom_f2c_flag_type_node;
 277 tree ffecom_f2c_ftnlen_type_node;
 278 tree ffecom_f2c_ftnlen_zero_node;
 279 tree ffecom_f2c_ftnlen_one_node;
 280 tree ffecom_f2c_ftnlen_two_node;
 281 tree ffecom_f2c_ptr_to_ftnlen_type_node;
 282 tree ffecom_f2c_ftnint_type_node;
 283 tree ffecom_f2c_ptr_to_ftnint_type_node;
 284 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 285
 286 /* Simple definitions and enumerations. */
 287
 288 #ifndef FFECOM_sizeMAXSTACKITEM
 289 #define FFECOM_sizeMAXSTACKITEM 32*1024 /* Keep user-declared things
 290                                            larger than this # bytes
 291                                            off stack if possible. */
 292 #endif
 293
 294 /* For systems that have large enough stacks, they should define
 295    this to 0, and here, for ease of use later on, we just undefine
 296    it if it is 0.  */
 297
 298 #if FFECOM_sizeMAXSTACKITEM == 0
 299 #undef FFECOM_sizeMAXSTACKITEM
 300 #endif
 301
 302 typedef enum
 303   {
 304     FFECOM_rttypeVOID_,
 305     FFECOM_rttypeVOIDSTAR_,     /* C's `void *' type. */
 306     FFECOM_rttypeFTNINT_,       /* f2c's `ftnint' type. */
 307     FFECOM_rttypeINTEGER_,      /* f2c's `integer' type. */
 308     FFECOM_rttypeLONGINT_,      /* f2c's `longint' type. */
 309     FFECOM_rttypeLOGICAL_,      /* f2c's `logical' type. */
 310     FFECOM_rttypeREAL_F2C_,     /* f2c's `real' returned as `double'. */
 311     FFECOM_rttypeREAL_GNU_,     /* `real' returned as such. */
 312     FFECOM_rttypeCOMPLEX_F2C_,  /* f2c's `complex' returned via 1st arg. */
 313     FFECOM_rttypeCOMPLEX_GNU_,  /* f2c's `complex' returned directly. */
 314     FFECOM_rttypeDOUBLE_,       /* C's `double' type. */
 315     FFECOM_rttypeDOUBLEREAL_,   /* f2c's `doublereal' type. */
 316     FFECOM_rttypeDBLCMPLX_F2C_, /* f2c's `doublecomplex' returned via 1st arg. */
 317     FFECOM_rttypeDBLCMPLX_GNU_, /* f2c's `doublecomplex' returned directly. */
 318     FFECOM_rttypeCHARACTER_,    /* f2c `char *'/`ftnlen' pair. */
 319     FFECOM_rttype_
 320   } ffecomRttype_;
 321
 322 /* Internal typedefs. */
 323
 324 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 325 typedef struct _ffecom_concat_list_ ffecomConcatList_;
 326 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 327
 328 /* Private include files. */
 329
 330
 331 /* Internal structure definitions. */
 332
 333 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 334 struct _ffecom_concat_list_
 335   {
 336     ffebld *exprs;
 337     int count;
 338     int max;
 339     ffetargetCharacterSize minlen;
 340     ffetargetCharacterSize maxlen;
 341   };
 342 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 343
 344 /* Static functions (internal). */
 345
 346 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 347 static tree ffecom_arglist_expr_ (const char *argstring, ffebld args);
 348 static tree ffecom_widest_expr_type_ (ffebld list);
 349 static bool ffecom_overlap_ (tree dest_decl, tree dest_offset,
 350                              tree dest_size, tree source_tree,
 351                              ffebld source, bool scalar_arg);
 352 static bool ffecom_args_overlapping_ (tree dest_tree, ffebld dest,
 353                                       tree args, tree callee_commons,
 354                                       bool scalar_args);
 355 static tree ffecom_build_f2c_string_ (int i, const char *s);
 356 static tree ffecom_call_ (tree fn, ffeinfoKindtype kt,
 357                           bool is_f2c_complex, tree type,
 358                           tree args, tree dest_tree,
 359                           ffebld dest, bool *dest_used,
 360                           tree callee_commons, bool scalar_args, tree hook);
 361 static tree ffecom_call_binop_ (tree fn, ffeinfoKindtype kt,
 362                                 bool is_f2c_complex, tree type,
 363                                 ffebld left, ffebld right,
 364                                 tree dest_tree, ffebld dest,
 365                                 bool *dest_used, tree callee_commons,
 366                                 bool scalar_args, bool ref, tree hook);
 367 static void ffecom_char_args_x_ (tree *xitem, tree *length,
 368                                  ffebld expr, bool with_null);
 369 static tree ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy);
 370 static tree ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s);
 371 static ffecomConcatList_
 372   ffecom_concat_list_gather_ (ffecomConcatList_ catlist,
 373                               ffebld expr,
 374                               ffetargetCharacterSize max);
 375 static void ffecom_concat_list_kill_ (ffecomConcatList_ catlist);
 376 static ffecomConcatList_ ffecom_concat_list_new_ (ffebld expr,
 377                                                 ffetargetCharacterSize max);
 378 static void ffecom_debug_kludge_ (tree aggr, const char *aggr_type,
 379                                   ffesymbol member, tree member_type,
 380                                   ffetargetOffset offset);
 381 static void ffecom_do_entry_ (ffesymbol fn, int entrynum);
 382 static tree ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
 383                           bool *dest_used, bool assignp, bool widenp);
 384 static tree ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
 385                                     ffebld dest, bool *dest_used);
 386 static tree ffecom_expr_power_integer_ (ffebld expr);
 387 static void ffecom_expr_transform_ (ffebld expr);
 388 static void ffecom_f2c_make_type_ (tree *type, int tcode, const char *name);
 389 static void ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
 390                                       int code);
 391 static ffeglobal ffecom_finish_global_ (ffeglobal global);
 392 static ffesymbol ffecom_finish_symbol_transform_ (ffesymbol s);
 393 static tree ffecom_get_appended_identifier_ (char us, const char *text);
 394 static tree ffecom_get_external_identifier_ (ffesymbol s);
 395 static tree ffecom_get_identifier_ (const char *text);
 396 static tree ffecom_gen_sfuncdef_ (ffesymbol s,
 397                                   ffeinfoBasictype bt,
 398                                   ffeinfoKindtype kt);
 399 static const char *ffecom_gfrt_args_ (ffecomGfrt ix);
 400 static tree ffecom_gfrt_tree_ (ffecomGfrt ix);
 401 static tree ffecom_init_zero_ (tree decl);
 402 static tree ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
 403                                      tree *maybe_tree);
 404 static tree ffecom_intrinsic_len_ (ffebld expr);
 405 static void ffecom_let_char_ (tree dest_tree,
 406                               tree dest_length,
 407                               ffetargetCharacterSize dest_size,
 408                               ffebld source);
 409 static void ffecom_make_gfrt_ (ffecomGfrt ix);
 410 static void ffecom_member_phase1_ (ffestorag mst, ffestorag st);
 411 static void ffecom_member_phase2_ (ffestorag mst, ffestorag st);
 412 static void ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size,
 413                                       ffebld source);
 414 static void ffecom_push_dummy_decls_ (ffebld dumlist,
 415                                       bool stmtfunc);
 416 static void ffecom_start_progunit_ (void);
 417 static ffesymbol ffecom_sym_transform_ (ffesymbol s);
 418 static ffesymbol ffecom_sym_transform_assign_ (ffesymbol s);
 419 static void ffecom_transform_common_ (ffesymbol s);
 420 static void ffecom_transform_equiv_ (ffestorag st);
 421 static tree ffecom_transform_namelist_ (ffesymbol s);
 422 static void ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
 423                                        tree t);
 424 static void ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
 425                                        tree *size, tree tree);
 426 static tree ffecom_tree_divide_ (tree tree_type, tree left, tree right,
 427                                  tree dest_tree, ffebld dest,
 428                                  bool *dest_used, tree hook);
 429 static tree ffecom_type_localvar_ (ffesymbol s,
 430                                    ffeinfoBasictype bt,
 431                                    ffeinfoKindtype kt);
 432 static tree ffecom_type_namelist_ (void);
 433 static tree ffecom_type_vardesc_ (void);
 434 static tree ffecom_vardesc_ (ffebld expr);
 435 static tree ffecom_vardesc_array_ (ffesymbol s);
 436 static tree ffecom_vardesc_dims_ (ffesymbol s);
 437 static tree ffecom_convert_narrow_ (tree type, tree expr);
 438 static tree ffecom_convert_widen_ (tree type, tree expr);
 439 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 440
 441 /* These are static functions that parallel those found in the C front
 442    end and thus have the same names.  */
 443
 444 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 445 static tree bison_rule_compstmt_ (void);
 446 static void bison_rule_pushlevel_ (void);
 447 static void delete_block (tree block);
 448 static int duplicate_decls (tree newdecl, tree olddecl);
 449 static void finish_decl (tree decl, tree init, bool is_top_level);
 450 static void finish_function (int nested);
 451 static const char *lang_printable_name (tree decl, int v);
 452 static tree lookup_name_current_level (tree name);
 453 static struct binding_level *make_binding_level (void);
 454 static void pop_f_function_context (void);
 455 static void push_f_function_context (void);
 456 static void push_parm_decl (tree parm);
 457 static tree pushdecl_top_level (tree decl);
 458 static int kept_level_p (void);
 459 static tree storedecls (tree decls);
 460 static void store_parm_decls (int is_main_program);
 461 static tree start_decl (tree decl, bool is_top_level);
 462 static void start_function (tree name, tree type, int nested, int public);
 463 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 464 #if FFECOM_GCC_INCLUDE
 465 static void ffecom_file_ (const char *name);
 466 static void ffecom_initialize_char_syntax_ (void);
 467 static void ffecom_close_include_ (FILE *f);
 468 static int ffecom_decode_include_option_ (char *spec);
 469 static FILE *ffecom_open_include_ (char *name, ffewhereLine l,
 470                                    ffewhereColumn c);
 471 #endif  /* FFECOM_GCC_INCLUDE */
 472
 473 /* Static objects accessed by functions in this module. */
 474
 475 static ffesymbol ffecom_primary_entry_ = NULL;
 476 static ffesymbol ffecom_nested_entry_ = NULL;
 477 static ffeinfoKind ffecom_primary_entry_kind_;
 478 static bool ffecom_primary_entry_is_proc_;
 479 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 480 static tree ffecom_outer_function_decl_;
 481 static tree ffecom_previous_function_decl_;
 482 static tree ffecom_which_entrypoint_decl_;
 483 static tree ffecom_float_zero_ = NULL_TREE;
 484 static tree ffecom_float_half_ = NULL_TREE;
 485 static tree ffecom_double_zero_ = NULL_TREE;
 486 static tree ffecom_double_half_ = NULL_TREE;
 487 static tree ffecom_func_result_;/* For functions. */
 488 static tree ffecom_func_length_;/* For CHARACTER fns. */
 489 static ffebld ffecom_list_blockdata_;
 490 static ffebld ffecom_list_common_;
 491 static ffebld ffecom_master_arglist_;
 492 static ffeinfoBasictype ffecom_master_bt_;
 493 static ffeinfoKindtype ffecom_master_kt_;
 494 static ffetargetCharacterSize ffecom_master_size_;
 495 static int ffecom_num_fns_ = 0;
 496 static int ffecom_num_entrypoints_ = 0;
 497 static bool ffecom_is_altreturning_ = FALSE;
 498 static tree ffecom_multi_type_node_;
 499 static tree ffecom_multi_retval_;
 500 static tree
 501   ffecom_multi_fields_[FFEINFO_basictype][FFEINFO_kindtype];
 502 static bool ffecom_member_namelisted_;  /* _member_phase1_ namelisted? */
 503 static bool ffecom_doing_entry_ = FALSE;
 504 static bool ffecom_transform_only_dummies_ = FALSE;
 505 static int ffecom_typesize_pointer_;
 506 static int ffecom_typesize_integer1_;
 507
 508 /* Holds pointer-to-function expressions.  */
 509
 510 static tree ffecom_gfrt_[FFECOM_gfrt]
 511 =
 512 {
 513 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NULL_TREE,
 514 #include "com-rt.def"
 515 #undef DEFGFRT
 516 };
 517
 518 /* Holds the external names of the functions.  */
 519
 520 static const char *ffecom_gfrt_name_[FFECOM_gfrt]
 521 =
 522 {
 523 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NAME,
 524 #include "com-rt.def"
 525 #undef DEFGFRT
 526 };
 527
 528 /* Whether the function returns.  */
 529
 530 static bool ffecom_gfrt_volatile_[FFECOM_gfrt]
 531 =
 532 {
 533 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) VOLATILE,
 534 #include "com-rt.def"
 535 #undef DEFGFRT
 536 };
 537
 538 /* Whether the function returns type complex.  */
 539
 540 static bool ffecom_gfrt_complex_[FFECOM_gfrt]
 541 =
 542 {
 543 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) COMPLEX,
 544 #include "com-rt.def"
 545 #undef DEFGFRT
 546 };
 547
 548 /* Whether the function is const
 549    (i.e., has no side effects and only depends on its arguments).  */
 550
 551 static bool ffecom_gfrt_const_[FFECOM_gfrt]
 552 =
 553 {
 554 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) CONST,
 555 #include "com-rt.def"
 556 #undef DEFGFRT
 557 };
 558
 559 /* Type code for the function return value.  */
 560
 561 static ffecomRttype_ ffecom_gfrt_type_[FFECOM_gfrt]
 562 =
 563 {
 564 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) TYPE,
 565 #include "com-rt.def"
 566 #undef DEFGFRT
 567 };
 568
 569 /* String of codes for the function's arguments.  */
 570
 571 static const char *ffecom_gfrt_argstring_[FFECOM_gfrt]
 572 =
 573 {
 574 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) ARGS,
 575 #include "com-rt.def"
 576 #undef DEFGFRT
 577 };
 578 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 579
 580 /* Internal macros. */
 581
 582 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 583
 584 /* We let tm.h override the types used here, to handle trivial differences
 585    such as the choice of unsigned int or long unsigned int for size_t.
 586    When machines start needing nontrivial differences in the size type,
 587    it would be best to do something here to figure out automatically
 588    from other information what type to use.  */
 589
 590 #ifndef SIZE_TYPE
 591 #define SIZE_TYPE "long unsigned int"
 592 #endif
 593
 594 #define ffecom_concat_list_count_(catlist) ((catlist).count)
 595 #define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)])
 596 #define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen)
 597 #define ffecom_concat_list_minlen_(catlist) ((catlist).minlen)
 598
 599 #define ffecom_char_args_(i,l,e) ffecom_char_args_x_((i),(l),(e),FALSE)
 600 #define ffecom_char_args_with_null_(i,l,e) ffecom_char_args_x_((i),(l),(e),TRUE)
 601
 602 /* For each binding contour we allocate a binding_level structure
 603  * which records the names defined in that contour.
 604  * Contours include:
 605  *  0) the global one
 606  *  1) one for each function definition,
 607  *     where internal declarations of the parameters appear.
 608  *
 609  * The current meaning of a name can be found by searching the levels from
 610  * the current one out to the global one.
 611  */
 612
 613 /* Note that the information in the `names' component of the global contour
 614    is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers.  */
 615
 616 struct binding_level
 617   {
 618     /* A chain of _DECL nodes for all variables, constants, functions,
 619        and typedef types.  These are in the reverse of the order supplied.
 620      */
 621     tree names;
 622
 623     /* For each level (except not the global one),
 624        a chain of BLOCK nodes for all the levels
 625        that were entered and exited one level down.  */
 626     tree blocks;
 627
 628     /* The BLOCK node for this level, if one has been preallocated.
 629        If 0, the BLOCK is allocated (if needed) when the level is popped.  */
 630     tree this_block;
 631
 632     /* The binding level which this one is contained in (inherits from).  */
 633     struct binding_level *level_chain;
 634
 635     /* 0: no ffecom_prepare_* functions called at this level yet;
 636        1: ffecom_prepare* functions called, except not ffecom_prepare_end;
 637        2: ffecom_prepare_end called.  */
 638     int prep_state;
 639   };
 640
 641 #define NULL_BINDING_LEVEL (struct binding_level *) NULL
 642
 643 /* The binding level currently in effect.  */
 644
 645 static struct binding_level *current_binding_level;
 646
 647 /* A chain of binding_level structures awaiting reuse.  */
 648
 649 static struct binding_level *free_binding_level;
 650
 651 /* The outermost binding level, for names of file scope.
 652    This is created when the compiler is started and exists
 653    through the entire run.  */
 654
 655 static struct binding_level *global_binding_level;
 656
 657 /* Binding level structures are initialized by copying this one.  */
 658
 659 static struct binding_level clear_binding_level
 660 =
 661 {NULL, NULL, NULL, NULL_BINDING_LEVEL, 0};
 662
 663 /* Language-dependent contents of an identifier.  */
 664
 665 struct lang_identifier
 666   {
 667     struct tree_identifier ignore;
 668     tree global_value, local_value, label_value;
 669     bool invented;
 670   };
 671
 672 /* Macros for access to language-specific slots in an identifier.  */
 673 /* Each of these slots contains a DECL node or null.  */
 674
 675 /* This represents the value which the identifier has in the
 676    file-scope namespace.  */
 677 #define IDENTIFIER_GLOBAL_VALUE(NODE)   \
 678   (((struct lang_identifier *)(NODE))->global_value)
 679 /* This represents the value which the identifier has in the current
 680    scope.  */
 681 #define IDENTIFIER_LOCAL_VALUE(NODE)    \
 682   (((struct lang_identifier *)(NODE))->local_value)
 683 /* This represents the value which the identifier has as a label in
 684    the current label scope.  */
 685 #define IDENTIFIER_LABEL_VALUE(NODE)    \
 686   (((struct lang_identifier *)(NODE))->label_value)
 687 /* This is nonzero if the identifier was "made up" by g77 code.  */
 688 #define IDENTIFIER_INVENTED(NODE)       \
 689   (((struct lang_identifier *)(NODE))->invented)
 690
 691 /* In identifiers, C uses the following fields in a special way:
 692    TREE_PUBLIC        to record that there was a previous local extern decl.
 693    TREE_USED          to record that such a decl was used.
 694    TREE_ADDRESSABLE   to record that the address of such a decl was used.  */
 695
 696 /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
 697    that have names.  Here so we can clear out their names' definitions
 698    at the end of the function.  */
 699
 700 static tree named_labels;
 701
 702 /* A list of LABEL_DECLs from outer contexts that are currently shadowed.  */
 703
 704 static tree shadowed_labels;
 705
 706 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 707 \f
 708 /* Return the subscript expression, modified to do range-checking.
 709
 710    `array' is the array to be checked against.
 711    `element' is the subscript expression to check.
 712    `dim' is the dimension number (starting at 0).
 713    `total_dims' is the total number of dimensions (0 for CHARACTER substring).
 714 */
 715
 716 static tree
 717 ffecom_subscript_check_ (tree array, tree element, int dim, int total_dims,
 718                          const char *array_name)
 719 {
 720   tree low = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 721   tree high = TYPE_MAX_VALUE (TYPE_DOMAIN (array));
 722   tree cond;
 723   tree die;
 724   tree args;
 725
 726   if (element == error_mark_node)
 727     return element;
 728
 729   if (TREE_TYPE (low) != TREE_TYPE (element))
 730     {
 731       if (TYPE_PRECISION (TREE_TYPE (low))
 732           > TYPE_PRECISION (TREE_TYPE (element)))
 733         element = convert (TREE_TYPE (low), element);
 734       else
 735         {
 736           low = convert (TREE_TYPE (element), low);
 737           if (high)
 738             high = convert (TREE_TYPE (element), high);
 739         }
 740     }
 741
 742   element = ffecom_save_tree (element);
 743   cond = ffecom_2 (LE_EXPR, integer_type_node,
 744                    low,
 745                    element);
 746   if (high)
 747     {
 748       cond = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
 749                        cond,
 750                        ffecom_2 (LE_EXPR, integer_type_node,
 751                                  element,
 752                                  high));
 753     }
 754
 755   {
 756     int len;
 757     char *proc;
 758     char *var;
 759     tree arg3;
 760     tree arg2;
 761     tree arg1;
 762     tree arg4;
 763
 764     switch (total_dims)
 765       {
 766       case 0:
 767         var = xmalloc (strlen (array_name) + 20);
 768         sprintf (var, "%s[%s-substring]",
 769                  array_name,
 770                  dim ? "end" : "start");
 771         len = strlen (var) + 1;
 772         arg1 = build_string (len, var);
 773         free (var);
 774         break;
 775
 776       case 1:
 777         len = strlen (array_name) + 1;
 778         arg1 = build_string (len, array_name);
 779         break;
 780
 781       default:
 782         var = xmalloc (strlen (array_name) + 40);
 783         sprintf (var, "%s[subscript-%d-of-%d]",
 784                  array_name,
 785                  dim + 1, total_dims);
 786         len = strlen (var) + 1;
 787         arg1 = build_string (len, var);
 788         free (var);
 789         break;
 790       }
 791
 792     TREE_TYPE (arg1)
 793       = build_type_variant (build_array_type (char_type_node,
 794                                               build_range_type
 795                                               (integer_type_node,
 796                                                integer_one_node,
 797                                                build_int_2 (len, 0))),
 798                             1, 0);
 799     TREE_CONSTANT (arg1) = 1;
 800     TREE_STATIC (arg1) = 1;
 801     arg1 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg1)),
 802                      arg1);
 803
 804     /* s_rnge adds one to the element to print it, so bias against
 805        that -- want to print a faithful *subscript* value.  */
 806     arg2 = convert (ffecom_f2c_ftnint_type_node,
 807                     ffecom_2 (MINUS_EXPR,
 808                               TREE_TYPE (element),
 809                               element,
 810                               convert (TREE_TYPE (element),
 811                                        integer_one_node)));
 812
 813     proc = xmalloc ((len = strlen (input_filename)
 814                      + IDENTIFIER_LENGTH (DECL_NAME (current_function_decl))
 815                      + 2));
 816
 817     sprintf (&proc[0], "%s/%s",
 818              input_filename,
 819              IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
 820     arg3 = build_string (len, proc);
 821
 822     free (proc);
 823
 824     TREE_TYPE (arg3)
 825       = build_type_variant (build_array_type (char_type_node,
 826                                               build_range_type
 827                                               (integer_type_node,
 828                                                integer_one_node,
 829                                                build_int_2 (len, 0))),
 830                             1, 0);
 831     TREE_CONSTANT (arg3) = 1;
 832     TREE_STATIC (arg3) = 1;
 833     arg3 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg3)),
 834                      arg3);
 835
 836     arg4 = convert (ffecom_f2c_ftnint_type_node,
 837                     build_int_2 (lineno, 0));
 838
 839     arg1 = build_tree_list (NULL_TREE, arg1);
 840     arg2 = build_tree_list (NULL_TREE, arg2);
 841     arg3 = build_tree_list (NULL_TREE, arg3);
 842     arg4 = build_tree_list (NULL_TREE, arg4);
 843     TREE_CHAIN (arg3) = arg4;
 844     TREE_CHAIN (arg2) = arg3;
 845     TREE_CHAIN (arg1) = arg2;
 846
 847     args = arg1;
 848   }
 849   die = ffecom_call_gfrt (FFECOM_gfrtRANGE,
 850                           args, NULL_TREE);
 851   TREE_SIDE_EFFECTS (die) = 1;
 852
 853   element = ffecom_3 (COND_EXPR,
 854                       TREE_TYPE (element),
 855                       cond,
 856                       element,
 857                       die);
 858
 859   return element;
 860 }
 861
 862 /* Return the computed element of an array reference.
 863
 864    `item' is NULL_TREE, or the transformed pointer to the array.
 865    `expr' is the original opARRAYREF expression, which is transformed
 866      if `item' is NULL_TREE.
 867    `want_ptr' is non-zero if a pointer to the element, instead of
 868      the element itself, is to be returned.  */
 869
 870 static tree
 871 ffecom_arrayref_ (tree item, ffebld expr, int want_ptr)
 872 {
 873   ffebld dims[FFECOM_dimensionsMAX];
 874   int i;
 875   int total_dims;
 876   int flatten = ffe_is_flatten_arrays ();
 877   int need_ptr;
 878   tree array;
 879   tree element;
 880   tree tree_type;
 881   tree tree_type_x;
 882   const char *array_name;
 883   ffetype type;
 884   ffebld list;
 885
 886   if (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER)
 887     array_name = ffesymbol_text (ffebld_symter (ffebld_left (expr)));
 888   else
 889     array_name = "[expr?]";
 890
 891   /* Build up ARRAY_REFs in reverse order (since we're column major
 892      here in Fortran land). */
 893
 894   for (i = 0, list = ffebld_right (expr);
 895        list != NULL;
 896        ++i, list = ffebld_trail (list))
 897     {
 898       dims[i] = ffebld_head (list);
 899       type = ffeinfo_type (ffebld_basictype (dims[i]),
 900                            ffebld_kindtype (dims[i]));
 901       if (! flatten
 902           && ffecom_typesize_pointer_ > ffecom_typesize_integer1_
 903           && ffetype_size (type) > ffecom_typesize_integer1_)
 904         /* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit
 905            pointers and 32-bit integers.  Do the full 64-bit pointer
 906            arithmetic, for codes using arrays for nonstandard heap-like
 907            work.  */
 908         flatten = 1;
 909     }
 910
 911   total_dims = i;
 912
 913   need_ptr = want_ptr || flatten;
 914
 915   if (! item)
 916     {
 917       if (need_ptr)
 918         item = ffecom_ptr_to_expr (ffebld_left (expr));
 919       else
 920         item = ffecom_expr (ffebld_left (expr));
 921
 922       if (item == error_mark_node)
 923         return item;
 924
 925       if (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING
 926           && ! mark_addressable (item))
 927         return error_mark_node;
 928     }
 929
 930   if (item == error_mark_node)
 931     return item;
 932
 933   if (need_ptr)
 934     {
 935       tree min;
 936
 937       for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
 938            i >= 0;
 939            --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
 940         {
 941           min = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 942           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 943           if (flag_bounds_check)
 944             element = ffecom_subscript_check_ (array, element, i, total_dims,
 945                                                array_name);
 946           if (element == error_mark_node)
 947             return element;
 948
 949           /* Widen integral arithmetic as desired while preserving
 950              signedness.  */
 951           tree_type = TREE_TYPE (element);
 952           tree_type_x = tree_type;
 953           if (tree_type
 954               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
 955               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
 956             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
 957
 958           if (TREE_TYPE (min) != tree_type_x)
 959             min = convert (tree_type_x, min);
 960           if (TREE_TYPE (element) != tree_type_x)
 961             element = convert (tree_type_x, element);
 962
 963           item = ffecom_2 (PLUS_EXPR,
 964                            build_pointer_type (TREE_TYPE (array)),
 965                            item,
 966                            size_binop (MULT_EXPR,
 967                                        size_in_bytes (TREE_TYPE (array)),
 968                                        convert (sizetype,
 969                                                 fold (build (MINUS_EXPR,
 970                                                              tree_type_x,
 971                                                              element, min)))));
 972         }
 973       if (! want_ptr)
 974         {
 975           item = ffecom_1 (INDIRECT_REF,
 976                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
 977                            item);
 978         }
 979     }
 980   else
 981     {
 982       for (--i;
 983            i >= 0;
 984            --i)
 985         {
 986           array = TYPE_MAIN_VARIANT (TREE_TYPE (item));
 987
 988           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 989           if (flag_bounds_check)
 990             element = ffecom_subscript_check_ (array, element, i, total_dims,
 991                                                array_name);
 992           if (element == error_mark_node)
 993             return element;
 994
 995           /* Widen integral arithmetic as desired while preserving
 996              signedness.  */
 997           tree_type = TREE_TYPE (element);
 998           tree_type_x = tree_type;
 999           if (tree_type
1000               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
1001               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
1002             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
1003
1004           element = convert (tree_type_x, element);
1005
1006           item = ffecom_2 (ARRAY_REF,
1007                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
1008                            item,
1009                            element);
1010         }
1011     }
1012
1013   return item;
1014 }
1015
1016 /* This is like gcc's stabilize_reference -- in fact, most of the code
1017    comes from that -- but it handles the situation where the reference
1018    is going to have its subparts picked at, and it shouldn't change
1019    (or trigger extra invocations of functions in the subtrees) due to
1020    this.  save_expr is a bit overzealous, because we don't need the
1021    entire thing calculated and saved like a temp.  So, for DECLs, no
1022    change is needed, because these are stable aggregates, and ARRAY_REF
1023    and such might well be stable too, but for things like calculations,
1024    we do need to calculate a snapshot of a value before picking at it.  */
1025
1026 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1027 static tree
1028 ffecom_stabilize_aggregate_ (tree ref)
1029 {
1030   tree result;
1031   enum tree_code code = TREE_CODE (ref);
1032
1033   switch (code)
1034     {
1035     case VAR_DECL:
1036     case PARM_DECL:
1037     case RESULT_DECL:
1038       /* No action is needed in this case.  */
1039       return ref;
1040
1041     case NOP_EXPR:
1042     case CONVERT_EXPR:
1043     case FLOAT_EXPR:
1044     case FIX_TRUNC_EXPR:
1045     case FIX_FLOOR_EXPR:
1046     case FIX_ROUND_EXPR:
1047     case FIX_CEIL_EXPR:
1048       result = build_nt (code, stabilize_reference (TREE_OPERAND (ref, 0)));
1049       break;
1050
1051     case INDIRECT_REF:
1052       result = build_nt (INDIRECT_REF,
1053                          stabilize_reference_1 (TREE_OPERAND (ref, 0)));
1054       break;
1055
1056     case COMPONENT_REF:
1057       result = build_nt (COMPONENT_REF,
1058                          stabilize_reference (TREE_OPERAND (ref, 0)),
1059                          TREE_OPERAND (ref, 1));
1060       break;
1061
1062     case BIT_FIELD_REF:
1063       result = build_nt (BIT_FIELD_REF,
1064                          stabilize_reference (TREE_OPERAND (ref, 0)),
1065                          stabilize_reference_1 (TREE_OPERAND (ref, 1)),
1066                          stabilize_reference_1 (TREE_OPERAND (ref, 2)));
1067       break;
1068
1069     case ARRAY_REF:
1070       result = build_nt (ARRAY_REF,
1071                          stabilize_reference (TREE_OPERAND (ref, 0)),
1072                          stabilize_reference_1 (TREE_OPERAND (ref, 1)));
1073       break;
1074
1075     case COMPOUND_EXPR:
1076       result = build_nt (COMPOUND_EXPR,
1077                          stabilize_reference_1 (TREE_OPERAND (ref, 0)),
1078                          stabilize_reference (TREE_OPERAND (ref, 1)));
1079       break;
1080
1081     case RTL_EXPR:
1082       abort ();
1083
1084
1085     default:
1086       return save_expr (ref);
1087
1088     case ERROR_MARK:
1089       return error_mark_node;
1090     }
1091
1092   TREE_TYPE (result) = TREE_TYPE (ref);
1093   TREE_READONLY (result) = TREE_READONLY (ref);
1094   TREE_SIDE_EFFECTS (result) = TREE_SIDE_EFFECTS (ref);
1095   TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
1096
1097   return result;
1098 }
1099 #endif
1100
1101 /* A rip-off of gcc's convert.c convert_to_complex function,
1102    reworked to handle complex implemented as C structures
1103    (RECORD_TYPE with two fields, real and imaginary `r' and `i').  */
1104
1105 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1106 static tree
1107 ffecom_convert_to_complex_ (tree type, tree expr)
1108 {
1109   register enum tree_code form = TREE_CODE (TREE_TYPE (expr));
1110   tree subtype;
1111
1112   assert (TREE_CODE (type) == RECORD_TYPE);
1113
1114   subtype = TREE_TYPE (TYPE_FIELDS (type));
1115
1116   if (form == REAL_TYPE || form == INTEGER_TYPE || form == ENUMERAL_TYPE)
1117     {
1118       expr = convert (subtype, expr);
1119       return ffecom_2 (COMPLEX_EXPR, type, expr,
1120                        convert (subtype, integer_zero_node));
1121     }
1122
1123   if (form == RECORD_TYPE)
1124     {
1125       tree elt_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr)));
1126       if (TYPE_MAIN_VARIANT (elt_type) == TYPE_MAIN_VARIANT (subtype))
1127         return expr;
1128       else
1129         {
1130           expr = save_expr (expr);
1131           return ffecom_2 (COMPLEX_EXPR,
1132                            type,
1133                            convert (subtype,
1134                                     ffecom_1 (REALPART_EXPR,
1135                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1136                                               expr)),
1137                            convert (subtype,
1138                                     ffecom_1 (IMAGPART_EXPR,
1139                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1140                                               expr)));
1141         }
1142     }
1143
1144   if (form == POINTER_TYPE || form == REFERENCE_TYPE)
1145     error ("pointer value used where a complex was expected");
1146   else
1147     error ("aggregate value used where a complex was expected");
1148
1149   return ffecom_2 (COMPLEX_EXPR, type,
1150                    convert (subtype, integer_zero_node),
1151                    convert (subtype, integer_zero_node));
1152 }
1153 #endif
1154
1155 /* Like gcc's convert(), but crashes if widening might happen.  */
1156
1157 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1158 static tree
1159 ffecom_convert_narrow_ (type, expr)
1160      tree type, expr;
1161 {
1162   register tree e = expr;
1163   register enum tree_code code = TREE_CODE (type);
1164
1165   if (type == TREE_TYPE (e)
1166       || TREE_CODE (e) == ERROR_MARK)
1167     return e;
1168   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1169     return fold (build1 (NOP_EXPR, type, e));
1170   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1171       || code == ERROR_MARK)
1172     return error_mark_node;
1173   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1174     {
1175       assert ("void value not ignored as it ought to be" == NULL);
1176       return error_mark_node;
1177     }
1178   assert (code != VOID_TYPE);
1179   if ((code != RECORD_TYPE)
1180       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1181     assert ("converting COMPLEX to REAL" == NULL);
1182   assert (code != ENUMERAL_TYPE);
1183   if (code == INTEGER_TYPE)
1184     {
1185       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1186                && TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)))
1187               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1188                   && (TYPE_PRECISION (type)
1189                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1190       return fold (convert_to_integer (type, e));
1191     }
1192   if (code == POINTER_TYPE)
1193     {
1194       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1195       return fold (convert_to_pointer (type, e));
1196     }
1197   if (code == REAL_TYPE)
1198     {
1199       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1200       assert (TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)));
1201       return fold (convert_to_real (type, e));
1202     }
1203   if (code == COMPLEX_TYPE)
1204     {
1205       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1206       assert (TYPE_PRECISION (TREE_TYPE (type)) <= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1207       return fold (convert_to_complex (type, e));
1208     }
1209   if (code == RECORD_TYPE)
1210     {
1211       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1212       /* Check that at least the first field name agrees.  */
1213       assert (DECL_NAME (TYPE_FIELDS (type))
1214               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1215       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1216               <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1217       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1218           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1219         return e;
1220       return fold (ffecom_convert_to_complex_ (type, e));
1221     }
1222
1223   assert ("conversion to non-scalar type requested" == NULL);
1224   return error_mark_node;
1225 }
1226 #endif
1227
1228 /* Like gcc's convert(), but crashes if narrowing might happen.  */
1229
1230 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1231 static tree
1232 ffecom_convert_widen_ (type, expr)
1233      tree type, expr;
1234 {
1235   register tree e = expr;
1236   register enum tree_code code = TREE_CODE (type);
1237
1238   if (type == TREE_TYPE (e)
1239       || TREE_CODE (e) == ERROR_MARK)
1240     return e;
1241   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1242     return fold (build1 (NOP_EXPR, type, e));
1243   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1244       || code == ERROR_MARK)
1245     return error_mark_node;
1246   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1247     {
1248       assert ("void value not ignored as it ought to be" == NULL);
1249       return error_mark_node;
1250     }
1251   assert (code != VOID_TYPE);
1252   if ((code != RECORD_TYPE)
1253       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1254     assert ("narrowing COMPLEX to REAL" == NULL);
1255   assert (code != ENUMERAL_TYPE);
1256   if (code == INTEGER_TYPE)
1257     {
1258       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1259                && TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)))
1260               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1261                   && (TYPE_PRECISION (type)
1262                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1263       return fold (convert_to_integer (type, e));
1264     }
1265   if (code == POINTER_TYPE)
1266     {
1267       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1268       return fold (convert_to_pointer (type, e));
1269     }
1270   if (code == REAL_TYPE)
1271     {
1272       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1273       assert (TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)));
1274       return fold (convert_to_real (type, e));
1275     }
1276   if (code == COMPLEX_TYPE)
1277     {
1278       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1279       assert (TYPE_PRECISION (TREE_TYPE (type)) >= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1280       return fold (convert_to_complex (type, e));
1281     }
1282   if (code == RECORD_TYPE)
1283     {
1284       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1285       /* Check that at least the first field name agrees.  */
1286       assert (DECL_NAME (TYPE_FIELDS (type))
1287               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1288       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1289               >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1290       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1291           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1292         return e;
1293       return fold (ffecom_convert_to_complex_ (type, e));
1294     }
1295
1296   assert ("conversion to non-scalar type requested" == NULL);
1297   return error_mark_node;
1298 }
1299 #endif
1300
1301 /* Handles making a COMPLEX type, either the standard
1302    (but buggy?) gbe way, or the safer (but less elegant?)
1303    f2c way.  */
1304
1305 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1306 static tree
1307 ffecom_make_complex_type_ (tree subtype)
1308 {
1309   tree type;
1310   tree realfield;
1311   tree imagfield;
1312
1313   if (ffe_is_emulate_complex ())
1314     {
1315       type = make_node (RECORD_TYPE);
1316       realfield = ffecom_decl_field (type, NULL_TREE, "r", subtype);
1317       imagfield = ffecom_decl_field (type, realfield, "i", subtype);
1318       TYPE_FIELDS (type) = realfield;
1319       layout_type (type);
1320     }
1321   else
1322     {
1323       type = make_node (COMPLEX_TYPE);
1324       TREE_TYPE (type) = subtype;
1325       layout_type (type);
1326     }
1327
1328   return type;
1329 }
1330 #endif
1331
1332 /* Chooses either the gbe or the f2c way to build a
1333    complex constant.  */
1334
1335 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1336 static tree
1337 ffecom_build_complex_constant_ (tree type, tree realpart, tree imagpart)
1338 {
1339   tree bothparts;
1340
1341   if (ffe_is_emulate_complex ())
1342     {
1343       bothparts = build_tree_list (TYPE_FIELDS (type), realpart);
1344       TREE_CHAIN (bothparts) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), imagpart);
1345       bothparts = build (CONSTRUCTOR, type, NULL_TREE, bothparts);
1346     }
1347   else
1348     {
1349       bothparts = build_complex (type, realpart, imagpart);
1350     }
1351
1352   return bothparts;
1353 }
1354 #endif
1355
1356 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1357 static tree
1358 ffecom_arglist_expr_ (const char *c, ffebld expr)
1359 {
1360   tree list;
1361   tree *plist = &list;
1362   tree trail = NULL_TREE;       /* Append char length args here. */
1363   tree *ptrail = &trail;
1364   tree length;
1365   ffebld exprh;
1366   tree item;
1367   bool ptr = FALSE;
1368   tree wanted = NULL_TREE;
1369   static char zed[] = "0";
1370
1371   if (c == NULL)
1372     c = &zed[0];
1373
1374   while (expr != NULL)
1375     {
1376       if (*c != '\0')
1377         {
1378           ptr = FALSE;
1379           if (*c == '&')
1380             {
1381               ptr = TRUE;
1382               ++c;
1383             }
1384           switch (*(c++))
1385             {
1386             case '\0':
1387               ptr = TRUE;
1388               wanted = NULL_TREE;
1389               break;
1390
1391             case 'a':
1392               assert (ptr);
1393               wanted = NULL_TREE;
1394               break;
1395
1396             case 'c':
1397               wanted = ffecom_f2c_complex_type_node;
1398               break;
1399
1400             case 'd':
1401               wanted = ffecom_f2c_doublereal_type_node;
1402               break;
1403
1404             case 'e':
1405               wanted = ffecom_f2c_doublecomplex_type_node;
1406               break;
1407
1408             case 'f':
1409               wanted = ffecom_f2c_real_type_node;
1410               break;
1411
1412             case 'i':
1413               wanted = ffecom_f2c_integer_type_node;
1414               break;
1415
1416             case 'j':
1417               wanted = ffecom_f2c_longint_type_node;
1418               break;
1419
1420             default:
1421               assert ("bad argstring code" == NULL);
1422               wanted = NULL_TREE;
1423               break;
1424             }
1425         }
1426
1427       exprh = ffebld_head (expr);
1428       if (exprh == NULL)
1429         wanted = NULL_TREE;
1430
1431       if ((wanted == NULL_TREE)
1432           || (ptr
1433               && (TYPE_MODE
1434                   (ffecom_tree_type[ffeinfo_basictype (ffebld_info (exprh))]
1435                    [ffeinfo_kindtype (ffebld_info (exprh))])
1436                    == TYPE_MODE (wanted))))
1437         *plist
1438           = build_tree_list (NULL_TREE,
1439                              ffecom_arg_ptr_to_expr (exprh,
1440                                                      &length));
1441       else
1442         {
1443           item = ffecom_arg_expr (exprh, &length);
1444           item = ffecom_convert_widen_ (wanted, item);
1445           if (ptr)
1446             {
1447               item = ffecom_1 (ADDR_EXPR,
1448                                build_pointer_type (TREE_TYPE (item)),
1449                                item);
1450             }
1451           *plist
1452             = build_tree_list (NULL_TREE,
1453                                item);
1454         }
1455
1456       plist = &TREE_CHAIN (*plist);
1457       expr = ffebld_trail (expr);
1458       if (length != NULL_TREE)
1459         {
1460           *ptrail = build_tree_list (NULL_TREE, length);
1461           ptrail = &TREE_CHAIN (*ptrail);
1462         }
1463     }
1464
1465   /* We've run out of args in the call; if the implementation expects
1466      more, supply null pointers for them, which the implementation can
1467      check to see if an arg was omitted. */
1468
1469   while (*c != '\0' && *c != '0')
1470     {
1471       if (*c == '&')
1472         ++c;
1473       else
1474         assert ("missing arg to run-time routine!" == NULL);
1475
1476       switch (*(c++))
1477         {
1478         case '\0':
1479         case 'a':
1480         case 'c':
1481         case 'd':
1482         case 'e':
1483         case 'f':
1484         case 'i':
1485         case 'j':
1486           break;
1487
1488         default:
1489           assert ("bad arg string code" == NULL);
1490           break;
1491         }
1492       *plist
1493         = build_tree_list (NULL_TREE,
1494                            null_pointer_node);
1495       plist = &TREE_CHAIN (*plist);
1496     }
1497
1498   *plist = trail;
1499
1500   return list;
1501 }
1502 #endif
1503
1504 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1505 static tree
1506 ffecom_widest_expr_type_ (ffebld list)
1507 {
1508   ffebld item;
1509   ffebld widest = NULL;
1510   ffetype type;
1511   ffetype widest_type = NULL;
1512   tree t;
1513
1514   for (; list != NULL; list = ffebld_trail (list))
1515     {
1516       item = ffebld_head (list);
1517       if (item == NULL)
1518         continue;
1519       if ((widest != NULL)
1520           && (ffeinfo_basictype (ffebld_info (item))
1521               != ffeinfo_basictype (ffebld_info (widest))))
1522         continue;
1523       type = ffeinfo_type (ffeinfo_basictype (ffebld_info (item)),
1524                            ffeinfo_kindtype (ffebld_info (item)));
1525       if ((widest == FFEINFO_kindtypeNONE)
1526           || (ffetype_size (type)
1527               > ffetype_size (widest_type)))
1528         {
1529           widest = item;
1530           widest_type = type;
1531         }
1532     }
1533
1534   assert (widest != NULL);
1535   t = ffecom_tree_type[ffeinfo_basictype (ffebld_info (widest))]
1536     [ffeinfo_kindtype (ffebld_info (widest))];
1537   assert (t != NULL_TREE);
1538   return t;
1539 }
1540 #endif
1541
1542 /* Check whether a partial overlap between two expressions is possible.
1543
1544    Can *starting* to write a portion of expr1 change the value
1545    computed (perhaps already, *partially*) by expr2?
1546
1547    Currently, this is a concern only for a COMPLEX expr1.  But if it
1548    isn't in COMMON or local EQUIVALENCE, since we don't support
1549    aliasing of arguments, it isn't a concern.  */
1550
1551 static bool
1552 ffecom_possible_partial_overlap_ (ffebld expr1, ffebld expr2 ATTRIBUTE_UNUSED)
1553 {
1554   ffesymbol sym;
1555   ffestorag st;
1556
1557   switch (ffebld_op (expr1))
1558     {
1559     case FFEBLD_opSYMTER:
1560       sym = ffebld_symter (expr1);
1561       break;
1562
1563     case FFEBLD_opARRAYREF:
1564       if (ffebld_op (ffebld_left (expr1)) != FFEBLD_opSYMTER)
1565         return FALSE;
1566       sym = ffebld_symter (ffebld_left (expr1));
1567       break;
1568
1569     default:
1570       return FALSE;
1571     }
1572
1573   if (ffesymbol_where (sym) != FFEINFO_whereCOMMON
1574       && (ffesymbol_where (sym) != FFEINFO_whereLOCAL
1575           || ! (st = ffesymbol_storage (sym))
1576           || ! ffestorag_parent (st)))
1577     return FALSE;
1578
1579   /* It's in COMMON or local EQUIVALENCE.  */
1580
1581   return TRUE;
1582 }
1583
1584 /* Check whether dest and source might overlap.  ffebld versions of these
1585    might or might not be passed, will be NULL if not.
1586
1587    The test is really whether source_tree is modifiable and, if modified,
1588    might overlap destination such that the value(s) in the destination might
1589    change before it is finally modified.  dest_* are the canonized
1590    destination itself.  */
1591
1592 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1593 static bool
1594 ffecom_overlap_ (tree dest_decl, tree dest_offset, tree dest_size,
1595                  tree source_tree, ffebld source UNUSED,
1596                  bool scalar_arg)
1597 {
1598   tree source_decl;
1599   tree source_offset;
1600   tree source_size;
1601   tree t;
1602
1603   if (source_tree == NULL_TREE)
1604     return FALSE;
1605
1606   switch (TREE_CODE (source_tree))
1607     {
1608     case ERROR_MARK:
1609     case IDENTIFIER_NODE:
1610     case INTEGER_CST:
1611     case REAL_CST:
1612     case COMPLEX_CST:
1613     case STRING_CST:
1614     case CONST_DECL:
1615     case VAR_DECL:
1616     case RESULT_DECL:
1617     case FIELD_DECL:
1618     case MINUS_EXPR:
1619     case MULT_EXPR:
1620     case TRUNC_DIV_EXPR:
1621     case CEIL_DIV_EXPR:
1622     case FLOOR_DIV_EXPR:
1623     case ROUND_DIV_EXPR:
1624     case TRUNC_MOD_EXPR:
1625     case CEIL_MOD_EXPR:
1626     case FLOOR_MOD_EXPR:
1627     case ROUND_MOD_EXPR:
1628     case RDIV_EXPR:
1629     case EXACT_DIV_EXPR:
1630     case FIX_TRUNC_EXPR:
1631     case FIX_CEIL_EXPR:
1632     case FIX_FLOOR_EXPR:
1633     case FIX_ROUND_EXPR:
1634     case FLOAT_EXPR:
1635     case EXPON_EXPR:
1636     case NEGATE_EXPR:
1637     case MIN_EXPR:
1638     case MAX_EXPR:
1639     case ABS_EXPR:
1640     case FFS_EXPR:
1641     case LSHIFT_EXPR:
1642     case RSHIFT_EXPR:
1643     case LROTATE_EXPR:
1644     case RROTATE_EXPR:
1645     case BIT_IOR_EXPR:
1646     case BIT_XOR_EXPR:
1647     case BIT_AND_EXPR:
1648     case BIT_ANDTC_EXPR:
1649     case BIT_NOT_EXPR:
1650     case TRUTH_ANDIF_EXPR:
1651     case TRUTH_ORIF_EXPR:
1652     case TRUTH_AND_EXPR:
1653     case TRUTH_OR_EXPR:
1654     case TRUTH_XOR_EXPR:
1655     case TRUTH_NOT_EXPR:
1656     case LT_EXPR:
1657     case LE_EXPR:
1658     case GT_EXPR:
1659     case GE_EXPR:
1660     case EQ_EXPR:
1661     case NE_EXPR:
1662     case COMPLEX_EXPR:
1663     case CONJ_EXPR:
1664     case REALPART_EXPR:
1665     case IMAGPART_EXPR:
1666     case LABEL_EXPR:
1667     case COMPONENT_REF:
1668       return FALSE;
1669
1670     case COMPOUND_EXPR:
1671       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1672                               TREE_OPERAND (source_tree, 1), NULL,
1673                               scalar_arg);
1674
1675     case MODIFY_EXPR:
1676       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1677                               TREE_OPERAND (source_tree, 0), NULL,
1678                               scalar_arg);
1679
1680     case CONVERT_EXPR:
1681     case NOP_EXPR:
1682     case NON_LVALUE_EXPR:
1683     case PLUS_EXPR:
1684       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1685         return TRUE;
1686
1687       ffecom_tree_canonize_ptr_ (&source_decl, &source_offset,
1688                                  source_tree);
1689       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1690       break;
1691
1692     case COND_EXPR:
1693       return
1694         ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1695                          TREE_OPERAND (source_tree, 1), NULL,
1696                          scalar_arg)
1697           || ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1698                               TREE_OPERAND (source_tree, 2), NULL,
1699                               scalar_arg);
1700
1701
1702     case ADDR_EXPR:
1703       ffecom_tree_canonize_ref_ (&source_decl, &source_offset,
1704                                  &source_size,
1705                                  TREE_OPERAND (source_tree, 0));
1706       break;
1707
1708     case PARM_DECL:
1709       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1710         return TRUE;
1711
1712       source_decl = source_tree;
1713       source_offset = bitsize_zero_node;
1714       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1715       break;
1716
1717     case SAVE_EXPR:
1718     case REFERENCE_EXPR:
1719     case PREDECREMENT_EXPR:
1720     case PREINCREMENT_EXPR:
1721     case POSTDECREMENT_EXPR:
1722     case POSTINCREMENT_EXPR:
1723     case INDIRECT_REF:
1724     case ARRAY_REF:
1725     case CALL_EXPR:
1726     default:
1727       return TRUE;
1728     }
1729
1730   /* Come here when source_decl, source_offset, and source_size filled
1731      in appropriately.  */
1732
1733   if (source_decl == NULL_TREE)
1734     return FALSE;               /* No decl involved, so no overlap. */
1735
1736   if (source_decl != dest_decl)
1737     return FALSE;               /* Different decl, no overlap. */
1738
1739   if (TREE_CODE (dest_size) == ERROR_MARK)
1740     return TRUE;                /* Assignment into entire assumed-size
1741                                    array?  Shouldn't happen.... */
1742
1743   t = ffecom_2 (LE_EXPR, integer_type_node,
1744                 ffecom_2 (PLUS_EXPR, TREE_TYPE (dest_offset),
1745                           dest_offset,
1746                           convert (TREE_TYPE (dest_offset),
1747                                    dest_size)),
1748                 convert (TREE_TYPE (dest_offset),
1749                          source_offset));
1750
1751   if (integer_onep (t))
1752     return FALSE;               /* Destination precedes source. */
1753
1754   if (!scalar_arg
1755       || (source_size == NULL_TREE)
1756       || (TREE_CODE (source_size) == ERROR_MARK)
1757       || integer_zerop (source_size))
1758     return TRUE;                /* No way to tell if dest follows source. */
1759
1760   t = ffecom_2 (LE_EXPR, integer_type_node,
1761                 ffecom_2 (PLUS_EXPR, TREE_TYPE (source_offset),
1762                           source_offset,
1763                           convert (TREE_TYPE (source_offset),
1764                                    source_size)),
1765                 convert (TREE_TYPE (source_offset),
1766                          dest_offset));
1767
1768   if (integer_onep (t))
1769     return FALSE;               /* Destination follows source. */
1770
1771   return TRUE;          /* Destination and source overlap. */
1772 }
1773 #endif
1774
1775 /* Check whether dest might overlap any of a list of arguments or is
1776    in a COMMON area the callee might know about (and thus modify).  */
1777
1778 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1779 static bool
1780 ffecom_args_overlapping_ (tree dest_tree, ffebld dest UNUSED,
1781                           tree args, tree callee_commons,
1782                           bool scalar_args)
1783 {
1784   tree arg;
1785   tree dest_decl;
1786   tree dest_offset;
1787   tree dest_size;
1788
1789   ffecom_tree_canonize_ref_ (&dest_decl, &dest_offset, &dest_size,
1790                              dest_tree);
1791
1792   if (dest_decl == NULL_TREE)
1793     return FALSE;               /* Seems unlikely! */
1794
1795   /* If the decl cannot be determined reliably, or if its in COMMON
1796      and the callee isn't known to not futz with COMMON via other
1797      means, overlap might happen.  */
1798
1799   if ((TREE_CODE (dest_decl) == ERROR_MARK)
1800       || ((callee_commons != NULL_TREE)
1801           && TREE_PUBLIC (dest_decl)))
1802     return TRUE;
1803
1804   for (; args != NULL_TREE; args = TREE_CHAIN (args))
1805     {
1806       if (((arg = TREE_VALUE (args)) != NULL_TREE)
1807           && ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1808                               arg, NULL, scalar_args))
1809         return TRUE;
1810     }
1811
1812   return FALSE;
1813 }
1814 #endif
1815
1816 /* Build a string for a variable name as used by NAMELIST.  This means that
1817    if we're using the f2c library, we build an uppercase string, since
1818    f2c does this.  */
1819
1820 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1821 static tree
1822 ffecom_build_f2c_string_ (int i, const char *s)
1823 {
1824   if (!ffe_is_f2c_library ())
1825     return build_string (i, s);
1826
1827   {
1828     char *tmp;
1829     const char *p;
1830     char *q;
1831     char space[34];
1832     tree t;
1833
1834     if (((size_t) i) > ARRAY_SIZE (space))
1835       tmp = malloc_new_ks (malloc_pool_image (), "f2c_string", i);
1836     else
1837       tmp = &space[0];
1838
1839     for (p = s, q = tmp; *p != '\0'; ++p, ++q)
1840       *q = TOUPPER (*p);
1841     *q = '\0';
1842
1843     t = build_string (i, tmp);
1844
1845     if (((size_t) i) > ARRAY_SIZE (space))
1846       malloc_kill_ks (malloc_pool_image (), tmp, i);
1847
1848     return t;
1849   }
1850 }
1851
1852 #endif
1853 /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
1854    type to just get whatever the function returns), handling the
1855    f2c value-returning convention, if required, by prepending
1856    to the arglist a pointer to a temporary to receive the return value.  */
1857
1858 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1859 static tree
1860 ffecom_call_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1861               tree type, tree args, tree dest_tree,
1862               ffebld dest, bool *dest_used, tree callee_commons,
1863               bool scalar_args, tree hook)
1864 {
1865   tree item;
1866   tree tempvar;
1867
1868   if (dest_used != NULL)
1869     *dest_used = FALSE;
1870
1871   if (is_f2c_complex)
1872     {
1873       if ((dest_used == NULL)
1874           || (dest == NULL)
1875           || (ffeinfo_basictype (ffebld_info (dest))
1876               != FFEINFO_basictypeCOMPLEX)
1877           || (ffeinfo_kindtype (ffebld_info (dest)) != kt)
1878           || ((type != NULL_TREE) && (TREE_TYPE (dest_tree) != type))
1879           || ffecom_args_overlapping_ (dest_tree, dest, args,
1880                                        callee_commons,
1881                                        scalar_args))
1882         {
1883 #ifdef HOHO
1884           tempvar = ffecom_make_tempvar (ffecom_tree_type
1885                                          [FFEINFO_basictypeCOMPLEX][kt],
1886                                          FFETARGET_charactersizeNONE,
1887                                          -1);
1888 #else
1889           tempvar = hook;
1890           assert (tempvar);
1891 #endif
1892         }
1893       else
1894         {
1895           *dest_used = TRUE;
1896           tempvar = dest_tree;
1897           type = NULL_TREE;
1898         }
1899
1900       item
1901         = build_tree_list (NULL_TREE,
1902                            ffecom_1 (ADDR_EXPR,
1903                                      build_pointer_type (TREE_TYPE (tempvar)),
1904                                      tempvar));
1905       TREE_CHAIN (item) = args;
1906
1907       item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1908                         item, NULL_TREE);
1909
1910       if (tempvar != dest_tree)
1911         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item, tempvar);
1912     }
1913   else
1914     item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1915                       args, NULL_TREE);
1916
1917   if ((type != NULL_TREE) && (TREE_TYPE (item) != type))
1918     item = ffecom_convert_narrow_ (type, item);
1919
1920   return item;
1921 }
1922 #endif
1923
1924 /* Given two arguments, transform them and make a call to the given
1925    function via ffecom_call_.  */
1926
1927 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1928 static tree
1929 ffecom_call_binop_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1930                     tree type, ffebld left, ffebld right,
1931                     tree dest_tree, ffebld dest, bool *dest_used,
1932                     tree callee_commons, bool scalar_args, bool ref, tree hook)
1933 {
1934   tree left_tree;
1935   tree right_tree;
1936   tree left_length;
1937   tree right_length;
1938
1939   if (ref)
1940     {
1941       /* Pass arguments by reference.  */
1942       left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
1943       right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
1944     }
1945   else
1946     {
1947       /* Pass arguments by value.  */
1948       left_tree = ffecom_arg_expr (left, &left_length);
1949       right_tree = ffecom_arg_expr (right, &right_length);
1950     }
1951
1952
1953   left_tree = build_tree_list (NULL_TREE, left_tree);
1954   right_tree = build_tree_list (NULL_TREE, right_tree);
1955   TREE_CHAIN (left_tree) = right_tree;
1956
1957   if (left_length != NULL_TREE)
1958     {
1959       left_length = build_tree_list (NULL_TREE, left_length);
1960       TREE_CHAIN (right_tree) = left_length;
1961     }
1962
1963   if (right_length != NULL_TREE)
1964     {
1965       right_length = build_tree_list (NULL_TREE, right_length);
1966       if (left_length != NULL_TREE)
1967         TREE_CHAIN (left_length) = right_length;
1968       else
1969         TREE_CHAIN (right_tree) = right_length;
1970     }
1971
1972   return ffecom_call_ (fn, kt, is_f2c_complex, type, left_tree,
1973                        dest_tree, dest, dest_used, callee_commons,
1974                        scalar_args, hook);
1975 }
1976 #endif
1977
1978 /* Return ptr/length args for char subexpression
1979
1980    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
1981    subexpressions by constructing the appropriate trees for the ptr-to-
1982    character-text and length-of-character-text arguments in a calling
1983    sequence.
1984
1985    Note that if with_null is TRUE, and the expression is an opCONTER,
1986    a null byte is appended to the string.  */
1987
1988 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1989 static void
1990 ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null)
1991 {
1992   tree item;
1993   tree high;
1994   ffetargetCharacter1 val;
1995   ffetargetCharacterSize newlen;
1996
1997   switch (ffebld_op (expr))
1998     {
1999     case FFEBLD_opCONTER:
2000       val = ffebld_constant_character1 (ffebld_conter (expr));
2001       newlen = ffetarget_length_character1 (val);
2002       if (with_null)
2003         {
2004           /* Begin FFETARGET-NULL-KLUDGE.  */
2005           if (newlen != 0)
2006             ++newlen;
2007         }
2008       *length = build_int_2 (newlen, 0);
2009       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2010       high = build_int_2 (newlen, 0);
2011       TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
2012       item = build_string (newlen,
2013                            ffetarget_text_character1 (val));
2014       /* End FFETARGET-NULL-KLUDGE.  */
2015       TREE_TYPE (item)
2016         = build_type_variant
2017           (build_array_type
2018            (char_type_node,
2019             build_range_type
2020             (ffecom_f2c_ftnlen_type_node,
2021              ffecom_f2c_ftnlen_one_node,
2022              high)),
2023            1, 0);
2024       TREE_CONSTANT (item) = 1;
2025       TREE_STATIC (item) = 1;
2026       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
2027                        item);
2028       break;
2029
2030     case FFEBLD_opSYMTER:
2031       {
2032         ffesymbol s = ffebld_symter (expr);
2033
2034         item = ffesymbol_hook (s).decl_tree;
2035         if (item == NULL_TREE)
2036           {
2037             s = ffecom_sym_transform_ (s);
2038             item = ffesymbol_hook (s).decl_tree;
2039           }
2040         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
2041           {
2042             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
2043               *length = ffesymbol_hook (s).length_tree;
2044             else
2045               {
2046                 *length = build_int_2 (ffesymbol_size (s), 0);
2047                 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2048               }
2049           }
2050         else if (item == error_mark_node)
2051           *length = error_mark_node;
2052         else
2053           /* FFEINFO_kindFUNCTION.  */
2054           *length = NULL_TREE;
2055         if (!ffesymbol_hook (s).addr
2056             && (item != error_mark_node))
2057           item = ffecom_1 (ADDR_EXPR,
2058                            build_pointer_type (TREE_TYPE (item)),
2059                            item);
2060       }
2061       break;
2062
2063     case FFEBLD_opARRAYREF:
2064       {
2065         ffecom_char_args_ (&item, length, ffebld_left (expr));
2066
2067         if (item == error_mark_node || *length == error_mark_node)
2068           {
2069             item = *length = error_mark_node;
2070             break;
2071           }
2072
2073         item = ffecom_arrayref_ (item, expr, 1);
2074       }
2075       break;
2076
2077     case FFEBLD_opSUBSTR:
2078       {
2079         ffebld start;
2080         ffebld end;
2081         ffebld thing = ffebld_right (expr);
2082         tree start_tree;
2083         tree end_tree;
2084         const char *char_name;
2085         ffebld left_symter;
2086         tree array;
2087
2088         assert (ffebld_op (thing) == FFEBLD_opITEM);
2089         start = ffebld_head (thing);
2090         thing = ffebld_trail (thing);
2091         assert (ffebld_trail (thing) == NULL);
2092         end = ffebld_head (thing);
2093
2094         /* Determine name for pretty-printing range-check errors.  */
2095         for (left_symter = ffebld_left (expr);
2096              left_symter && ffebld_op (left_symter) == FFEBLD_opARRAYREF;
2097              left_symter = ffebld_left (left_symter))
2098           ;
2099         if (ffebld_op (left_symter) == FFEBLD_opSYMTER)
2100           char_name = ffesymbol_text (ffebld_symter (left_symter));
2101         else
2102           char_name = "[expr?]";
2103
2104         ffecom_char_args_ (&item, length, ffebld_left (expr));
2105
2106         if (item == error_mark_node || *length == error_mark_node)
2107           {
2108             item = *length = error_mark_node;
2109             break;
2110           }
2111
2112         array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
2113
2114         /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF.  */
2115
2116         if (start == NULL)
2117           {
2118             if (end == NULL)
2119               ;
2120             else
2121               {
2122                 end_tree = ffecom_expr (end);
2123                 if (flag_bounds_check)
2124                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2125                                                       char_name);
2126                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2127                                     end_tree);
2128
2129                 if (end_tree == error_mark_node)
2130                   {
2131                     item = *length = error_mark_node;
2132                     break;
2133                   }
2134
2135                 *length = end_tree;
2136               }
2137           }
2138         else
2139           {
2140             start_tree = ffecom_expr (start);
2141             if (flag_bounds_check)
2142               start_tree = ffecom_subscript_check_ (array, start_tree, 0, 0,
2143                                                     char_name);
2144             start_tree = convert (ffecom_f2c_ftnlen_type_node,
2145                                   start_tree);
2146
2147             if (start_tree == error_mark_node)
2148               {
2149                 item = *length = error_mark_node;
2150                 break;
2151               }
2152
2153             start_tree = ffecom_save_tree (start_tree);
2154
2155             item = ffecom_2 (PLUS_EXPR, TREE_TYPE (item),
2156                              item,
2157                              ffecom_2 (MINUS_EXPR,
2158                                        TREE_TYPE (start_tree),
2159                                        start_tree,
2160                                        ffecom_f2c_ftnlen_one_node));
2161
2162             if (end == NULL)
2163               {
2164                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2165                                     ffecom_f2c_ftnlen_one_node,
2166                                     ffecom_2 (MINUS_EXPR,
2167                                               ffecom_f2c_ftnlen_type_node,
2168                                               *length,
2169                                               start_tree));
2170               }
2171             else
2172               {
2173                 end_tree = ffecom_expr (end);
2174                 if (flag_bounds_check)
2175                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2176                                                       char_name);
2177                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2178                                     end_tree);
2179
2180                 if (end_tree == error_mark_node)
2181                   {
2182                     item = *length = error_mark_node;
2183                     break;
2184                   }
2185
2186                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2187                                     ffecom_f2c_ftnlen_one_node,
2188                                     ffecom_2 (MINUS_EXPR,
2189                                               ffecom_f2c_ftnlen_type_node,
2190                                               end_tree, start_tree));
2191               }
2192           }
2193       }
2194       break;
2195
2196     case FFEBLD_opFUNCREF:
2197       {
2198         ffesymbol s = ffebld_symter (ffebld_left (expr));
2199         tree tempvar;
2200         tree args;
2201         ffetargetCharacterSize size = ffeinfo_size (ffebld_info (expr));
2202         ffecomGfrt ix;
2203
2204         if (size == FFETARGET_charactersizeNONE)
2205           /* ~~Kludge alert!  This should someday be fixed. */
2206           size = 24;
2207
2208         *length = build_int_2 (size, 0);
2209         TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2210
2211         if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
2212             == FFEINFO_whereINTRINSIC)
2213           {
2214             if (size == 1)
2215               {
2216                 /* Invocation of an intrinsic returning CHARACTER*1.  */
2217                 item = ffecom_expr_intrinsic_ (expr, NULL_TREE,
2218                                                NULL, NULL);
2219                 break;
2220               }
2221             ix = ffeintrin_gfrt_direct (ffebld_symter_implementation (ffebld_left (expr)));
2222             assert (ix != FFECOM_gfrt);
2223             item = ffecom_gfrt_tree_ (ix);
2224           }
2225         else
2226           {
2227             ix = FFECOM_gfrt;
2228             item = ffesymbol_hook (s).decl_tree;
2229             if (item == NULL_TREE)
2230               {
2231                 s = ffecom_sym_transform_ (s);
2232                 item = ffesymbol_hook (s).decl_tree;
2233               }
2234             if (item == error_mark_node)
2235               {
2236                 item = *length = error_mark_node;
2237                 break;
2238               }
2239
2240             if (!ffesymbol_hook (s).addr)
2241               item = ffecom_1_fn (item);
2242           }
2243
2244 #ifdef HOHO
2245         tempvar = ffecom_push_tempvar (char_type_node, size, -1, TRUE);
2246 #else
2247         tempvar = ffebld_nonter_hook (expr);
2248         assert (tempvar);
2249 #endif
2250         tempvar = ffecom_1 (ADDR_EXPR,
2251                             build_pointer_type (TREE_TYPE (tempvar)),
2252                             tempvar);
2253
2254         args = build_tree_list (NULL_TREE, tempvar);
2255
2256         if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)       /* Sfunc args by value. */
2257           TREE_CHAIN (args) = ffecom_list_expr (ffebld_right (expr));
2258         else
2259           {
2260             TREE_CHAIN (args) = build_tree_list (NULL_TREE, *length);
2261             if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
2262               {
2263                 TREE_CHAIN (TREE_CHAIN (args))
2264                   = ffecom_arglist_expr_ (ffecom_gfrt_args_ (ix),
2265                                           ffebld_right (expr));
2266               }
2267             else
2268               {
2269                 TREE_CHAIN (TREE_CHAIN (args))
2270                   = ffecom_list_ptr_to_expr (ffebld_right (expr));
2271               }
2272           }
2273
2274         item = ffecom_3s (CALL_EXPR,
2275                           TREE_TYPE (TREE_TYPE (TREE_TYPE (item))),
2276                           item, args, NULL_TREE);
2277         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item,
2278                          tempvar);
2279       }
2280       break;
2281
2282     case FFEBLD_opCONVERT:
2283
2284       ffecom_char_args_ (&item, length, ffebld_left (expr));
2285
2286       if (item == error_mark_node || *length == error_mark_node)
2287         {
2288           item = *length = error_mark_node;
2289           break;
2290         }
2291
2292       if ((ffebld_size_known (ffebld_left (expr))
2293            == FFETARGET_charactersizeNONE)
2294           || (ffebld_size_known (ffebld_left (expr)) < (ffebld_size (expr))))
2295         {                       /* Possible blank-padding needed, copy into
2296                                    temporary. */
2297           tree tempvar;
2298           tree args;
2299           tree newlen;
2300
2301 #ifdef HOHO
2302           tempvar = ffecom_make_tempvar (char_type_node,
2303                                          ffebld_size (expr), -1);
2304 #else
2305           tempvar = ffebld_nonter_hook (expr);
2306           assert (tempvar);
2307 #endif
2308           tempvar = ffecom_1 (ADDR_EXPR,
2309                               build_pointer_type (TREE_TYPE (tempvar)),
2310                               tempvar);
2311
2312           newlen = build_int_2 (ffebld_size (expr), 0);
2313           TREE_TYPE (newlen) = ffecom_f2c_ftnlen_type_node;
2314
2315           args = build_tree_list (NULL_TREE, tempvar);
2316           TREE_CHAIN (args) = build_tree_list (NULL_TREE, item);
2317           TREE_CHAIN (TREE_CHAIN (args)) = build_tree_list (NULL_TREE, newlen);
2318           TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args)))
2319             = build_tree_list (NULL_TREE, *length);
2320
2321           item = ffecom_call_gfrt (FFECOM_gfrtCOPY, args, NULL_TREE);
2322           TREE_SIDE_EFFECTS (item) = 1;
2323           item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), fold (item),
2324                            tempvar);
2325           *length = newlen;
2326         }
2327       else
2328         {                       /* Just truncate the length. */
2329           *length = build_int_2 (ffebld_size (expr), 0);
2330           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2331         }
2332       break;
2333
2334     default:
2335       assert ("bad op for single char arg expr" == NULL);
2336       item = NULL_TREE;
2337       break;
2338     }
2339
2340   *xitem = item;
2341 }
2342 #endif
2343
2344 /* Check the size of the type to be sure it doesn't overflow the
2345    "portable" capacities of the compiler back end.  `dummy' types
2346    can generally overflow the normal sizes as long as the computations
2347    themselves don't overflow.  A particular target of the back end
2348    must still enforce its size requirements, though, and the back
2349    end takes care of this in stor-layout.c.  */
2350
2351 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2352 static tree
2353 ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy)
2354 {
2355   if (TREE_CODE (type) == ERROR_MARK)
2356     return type;
2357
2358   if (TYPE_SIZE (type) == NULL_TREE)
2359     return type;
2360
2361   if (TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST)
2362     return type;
2363
2364   if ((tree_int_cst_sgn (TYPE_SIZE (type)) < 0)
2365       || (!dummy && (((TREE_INT_CST_HIGH (TYPE_SIZE (type)) != 0))
2366                      || TREE_OVERFLOW (TYPE_SIZE (type)))))
2367     {
2368       ffebad_start (FFEBAD_ARRAY_LARGE);
2369       ffebad_string (ffesymbol_text (s));
2370       ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
2371       ffebad_finish ();
2372
2373       return error_mark_node;
2374     }
2375
2376   return type;
2377 }
2378 #endif
2379
2380 /* Builds a length argument (PARM_DECL).  Also wraps type in an array type
2381    where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
2382    known, length_arg if not known (FFETARGET_charactersizeNONE).  */
2383
2384 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2385 static tree
2386 ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s)
2387 {
2388   ffetargetCharacterSize sz = ffesymbol_size (s);
2389   tree highval;
2390   tree tlen;
2391   tree type = *xtype;
2392
2393   if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
2394     tlen = NULL_TREE;           /* A statement function, no length passed. */
2395   else
2396     {
2397       if (ffesymbol_where (s) == FFEINFO_whereDUMMY)
2398         tlen = ffecom_get_invented_identifier ("__g77_length_%s",
2399                                                ffesymbol_text (s));
2400       else
2401         tlen = ffecom_get_invented_identifier ("__g77_%s", "length");
2402       tlen = build_decl (PARM_DECL, tlen, ffecom_f2c_ftnlen_type_node);
2403 #if BUILT_FOR_270
2404       DECL_ARTIFICIAL (tlen) = 1;
2405 #endif
2406     }
2407
2408   if (sz == FFETARGET_charactersizeNONE)
2409     {
2410       assert (tlen != NULL_TREE);
2411       highval = variable_size (tlen);
2412     }
2413   else
2414     {
2415       highval = build_int_2 (sz, 0);
2416       TREE_TYPE (highval) = ffecom_f2c_ftnlen_type_node;
2417     }
2418
2419   type = build_array_type (type,
2420                            build_range_type (ffecom_f2c_ftnlen_type_node,
2421                                              ffecom_f2c_ftnlen_one_node,
2422                                              highval));
2423
2424   *xtype = type;
2425   return tlen;
2426 }
2427
2428 #endif
2429 /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
2430
2431    ffecomConcatList_ catlist;
2432    ffebld expr;  // expr of CHARACTER basictype.
2433    ffetargetCharacterSize max;  // max chars to gather or _...NONE if no max
2434    catlist = ffecom_concat_list_gather_(catlist,expr,max);
2435
2436    Scans expr for character subexpressions, updates and returns catlist
2437    accordingly.  */
2438
2439 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2440 static ffecomConcatList_
2441 ffecom_concat_list_gather_ (ffecomConcatList_ catlist, ffebld expr,
2442                             ffetargetCharacterSize max)
2443 {
2444   ffetargetCharacterSize sz;
2445
2446 recurse:                        /* :::::::::::::::::::: */
2447
2448   if (expr == NULL)
2449     return catlist;
2450
2451   if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen >= max))
2452     return catlist;             /* Don't append any more items. */
2453
2454   switch (ffebld_op (expr))
2455     {
2456     case FFEBLD_opCONTER:
2457     case FFEBLD_opSYMTER:
2458     case FFEBLD_opARRAYREF:
2459     case FFEBLD_opFUNCREF:
2460     case FFEBLD_opSUBSTR:
2461     case FFEBLD_opCONVERT:      /* Callers should strip this off beforehand
2462                                    if they don't need to preserve it. */
2463       if (catlist.count == catlist.max)
2464         {                       /* Make a (larger) list. */
2465           ffebld *newx;
2466           int newmax;
2467
2468           newmax = (catlist.max == 0) ? 8 : catlist.max * 2;
2469           newx = malloc_new_ks (malloc_pool_image (), "catlist",
2470                                 newmax * sizeof (newx[0]));
2471           if (catlist.max != 0)
2472             {
2473               memcpy (newx, catlist.exprs, catlist.max * sizeof (newx[0]));
2474               malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2475                               catlist.max * sizeof (newx[0]));
2476             }
2477           catlist.max = newmax;
2478           catlist.exprs = newx;
2479         }
2480       if ((sz = ffebld_size_known (expr)) != FFETARGET_charactersizeNONE)
2481         catlist.minlen += sz;
2482       else
2483         ++catlist.minlen;       /* Not true for F90; can be 0 length. */
2484       if ((sz = ffebld_size_max (expr)) == FFETARGET_charactersizeNONE)
2485         catlist.maxlen = sz;
2486       else
2487         catlist.maxlen += sz;
2488       if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen > max))
2489         {                       /* This item overlaps (or is beyond) the end
2490                                    of the destination. */
2491           switch (ffebld_op (expr))
2492             {
2493             case FFEBLD_opCONTER:
2494             case FFEBLD_opSYMTER:
2495             case FFEBLD_opARRAYREF:
2496             case FFEBLD_opFUNCREF:
2497             case FFEBLD_opSUBSTR:
2498               /* ~~Do useful truncations here. */
2499               break;
2500
2501             default:
2502               assert ("op changed or inconsistent switches!" == NULL);
2503               break;
2504             }
2505         }
2506       catlist.exprs[catlist.count++] = expr;
2507       return catlist;
2508
2509     case FFEBLD_opPAREN:
2510       expr = ffebld_left (expr);
2511       goto recurse;             /* :::::::::::::::::::: */
2512
2513     case FFEBLD_opCONCATENATE:
2514       catlist = ffecom_concat_list_gather_ (catlist, ffebld_left (expr), max);
2515       expr = ffebld_right (expr);
2516       goto recurse;             /* :::::::::::::::::::: */
2517
2518 #if 0                           /* Breaks passing small actual arg to larger
2519                                    dummy arg of sfunc */
2520     case FFEBLD_opCONVERT:
2521       expr = ffebld_left (expr);
2522       {
2523         ffetargetCharacterSize cmax;
2524
2525         cmax = catlist.len + ffebld_size_known (expr);
2526
2527         if ((max == FFETARGET_charactersizeNONE) || (max > cmax))
2528           max = cmax;
2529       }
2530       goto recurse;             /* :::::::::::::::::::: */
2531 #endif
2532
2533     case FFEBLD_opANY:
2534       return catlist;
2535
2536     default:
2537       assert ("bad op in _gather_" == NULL);
2538       return catlist;
2539     }
2540 }
2541
2542 #endif
2543 /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
2544
2545    ffecomConcatList_ catlist;
2546    ffecom_concat_list_kill_(catlist);
2547
2548    Anything allocated within the list info is deallocated.  */
2549
2550 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2551 static void
2552 ffecom_concat_list_kill_ (ffecomConcatList_ catlist)
2553 {
2554   if (catlist.max != 0)
2555     malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2556                     catlist.max * sizeof (catlist.exprs[0]));
2557 }
2558
2559 #endif
2560 /* Make list of concatenated string exprs.
2561
2562    Returns a flattened list of concatenated subexpressions given a
2563    tree of such expressions.  */
2564
2565 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2566 static ffecomConcatList_
2567 ffecom_concat_list_new_ (ffebld expr, ffetargetCharacterSize max)
2568 {
2569   ffecomConcatList_ catlist;
2570
2571   catlist.maxlen = catlist.minlen = catlist.max = catlist.count = 0;
2572   return ffecom_concat_list_gather_ (catlist, expr, max);
2573 }
2574
2575 #endif
2576
2577 /* Provide some kind of useful info on member of aggregate area,
2578    since current g77/gcc technology does not provide debug info
2579    on these members.  */
2580
2581 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2582 static void
2583 ffecom_debug_kludge_ (tree aggr, const char *aggr_type, ffesymbol member,
2584                       tree member_type UNUSED, ffetargetOffset offset)
2585 {
2586   tree value;
2587   tree decl;
2588   int len;
2589   char *buff;
2590   char space[120];
2591 #if 0
2592   tree type_id;
2593
2594   for (type_id = member_type;
2595        TREE_CODE (type_id) != IDENTIFIER_NODE;
2596        )
2597     {
2598       switch (TREE_CODE (type_id))
2599         {
2600         case INTEGER_TYPE:
2601         case REAL_TYPE:
2602           type_id = TYPE_NAME (type_id);
2603           break;
2604
2605         case ARRAY_TYPE:
2606         case COMPLEX_TYPE:
2607           type_id = TREE_TYPE (type_id);
2608           break;
2609
2610         default:
2611           assert ("no IDENTIFIER_NODE for type!" == NULL);
2612           type_id = error_mark_node;
2613           break;
2614         }
2615     }
2616 #endif
2617
2618   if (ffecom_transform_only_dummies_
2619       || !ffe_is_debug_kludge ())
2620     return;     /* Can't do this yet, maybe later. */
2621
2622   len = 60
2623     + strlen (aggr_type)
2624     + IDENTIFIER_LENGTH (DECL_NAME (aggr));
2625 #if 0
2626     + IDENTIFIER_LENGTH (type_id);
2627 #endif
2628
2629   if (((size_t) len) >= ARRAY_SIZE (space))
2630     buff = malloc_new_ks (malloc_pool_image (), "debug_kludge", len + 1);
2631   else
2632     buff = &space[0];
2633
2634   sprintf (&buff[0], "At (%s) `%s' plus %ld bytes",
2635            aggr_type,
2636            IDENTIFIER_POINTER (DECL_NAME (aggr)),
2637            (long int) offset);
2638
2639   value = build_string (len, buff);
2640   TREE_TYPE (value)
2641     = build_type_variant (build_array_type (char_type_node,
2642                                             build_range_type
2643                                             (integer_type_node,
2644                                              integer_one_node,
2645                                              build_int_2 (strlen (buff), 0))),
2646                           1, 0);
2647   decl = build_decl (VAR_DECL,
2648                      ffecom_get_identifier_ (ffesymbol_text (member)),
2649                      TREE_TYPE (value));
2650   TREE_CONSTANT (decl) = 1;
2651   TREE_STATIC (decl) = 1;
2652   DECL_INITIAL (decl) = error_mark_node;
2653   DECL_IN_SYSTEM_HEADER (decl) = 1;     /* Don't let -Wunused complain. */
2654   decl = start_decl (decl, FALSE);
2655   finish_decl (decl, value, FALSE);
2656
2657   if (buff != &space[0])
2658     malloc_kill_ks (malloc_pool_image (), buff, len + 1);
2659 }
2660 #endif
2661
2662 /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
2663
2664    ffesymbol fn;  // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
2665    int i;  // entry# for this entrypoint (used by master fn)
2666    ffecom_do_entrypoint_(s,i);
2667
2668    Makes a public entry point that calls our private master fn (already
2669    compiled).  */
2670
2671 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2672 static void
2673 ffecom_do_entry_ (ffesymbol fn, int entrynum)
2674 {
2675   ffebld item;
2676   tree type;                    /* Type of function. */
2677   tree multi_retval;            /* Var holding return value (union). */
2678   tree result;                  /* Var holding result. */
2679   ffeinfoBasictype bt;
2680   ffeinfoKindtype kt;
2681   ffeglobal g;
2682   ffeglobalType gt;
2683   bool charfunc;                /* All entry points return same type
2684                                    CHARACTER. */
2685   bool cmplxfunc;               /* Use f2c way of returning COMPLEX. */
2686   bool multi;                   /* Master fn has multiple return types. */
2687   bool altreturning = FALSE;    /* This entry point has alternate returns. */
2688   int old_lineno = lineno;
2689   const char *old_input_filename = input_filename;
2690
2691   input_filename = ffesymbol_where_filename (fn);
2692   lineno = ffesymbol_where_filelinenum (fn);
2693
2694   ffecom_doing_entry_ = TRUE;   /* Don't bother with array dimensions. */
2695
2696   switch (ffecom_primary_entry_kind_)
2697     {
2698     case FFEINFO_kindFUNCTION:
2699
2700       /* Determine actual return type for function. */
2701
2702       gt = FFEGLOBAL_typeFUNC;
2703       bt = ffesymbol_basictype (fn);
2704       kt = ffesymbol_kindtype (fn);
2705       if (bt == FFEINFO_basictypeNONE)
2706         {
2707           ffeimplic_establish_symbol (fn);
2708           if (ffesymbol_funcresult (fn) != NULL)
2709             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
2710           bt = ffesymbol_basictype (fn);
2711           kt = ffesymbol_kindtype (fn);
2712         }
2713
2714       if (bt == FFEINFO_basictypeCHARACTER)
2715         charfunc = TRUE, cmplxfunc = FALSE;
2716       else if ((bt == FFEINFO_basictypeCOMPLEX)
2717                && ffesymbol_is_f2c (fn))
2718         charfunc = FALSE, cmplxfunc = TRUE;
2719       else
2720         charfunc = cmplxfunc = FALSE;
2721
2722       if (charfunc)
2723         type = ffecom_tree_fun_type_void;
2724       else if (ffesymbol_is_f2c (fn))
2725         type = ffecom_tree_fun_type[bt][kt];
2726       else
2727         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
2728
2729       if ((type == NULL_TREE)
2730           || (TREE_TYPE (type) == NULL_TREE))
2731         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
2732
2733       multi = (ffecom_master_bt_ == FFEINFO_basictypeNONE);
2734       break;
2735
2736     case FFEINFO_kindSUBROUTINE:
2737       gt = FFEGLOBAL_typeSUBR;
2738       bt = FFEINFO_basictypeNONE;
2739       kt = FFEINFO_kindtypeNONE;
2740       if (ffecom_is_altreturning_)
2741         {                       /* Am _I_ altreturning? */
2742           for (item = ffesymbol_dummyargs (fn);
2743                item != NULL;
2744                item = ffebld_trail (item))
2745             {
2746               if (ffebld_op (ffebld_head (item)) == FFEBLD_opSTAR)
2747                 {
2748                   altreturning = TRUE;
2749                   break;
2750                 }
2751             }
2752           if (altreturning)
2753             type = ffecom_tree_subr_type;
2754           else
2755             type = ffecom_tree_fun_type_void;
2756         }
2757       else
2758         type = ffecom_tree_fun_type_void;
2759       charfunc = FALSE;
2760       cmplxfunc = FALSE;
2761       multi = FALSE;
2762       break;
2763
2764     default:
2765       assert ("say what??" == NULL);
2766       /* Fall through. */
2767     case FFEINFO_kindANY:
2768       gt = FFEGLOBAL_typeANY;
2769       bt = FFEINFO_basictypeNONE;
2770       kt = FFEINFO_kindtypeNONE;
2771       type = error_mark_node;
2772       charfunc = FALSE;
2773       cmplxfunc = FALSE;
2774       multi = FALSE;
2775       break;
2776     }
2777
2778   /* build_decl uses the current lineno and input_filename to set the decl
2779      source info.  So, I've putzed with ffestd and ffeste code to update that
2780      source info to point to the appropriate statement just before calling
2781      ffecom_do_entrypoint (which calls this fn).  */
2782
2783   start_function (ffecom_get_external_identifier_ (fn),
2784                   type,
2785                   0,            /* nested/inline */
2786                   1);           /* TREE_PUBLIC */
2787
2788   if (((g = ffesymbol_global (fn)) != NULL)
2789       && ((ffeglobal_type (g) == gt)
2790           || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
2791     {
2792       ffeglobal_set_hook (g, current_function_decl);
2793     }
2794
2795   /* Reset args in master arg list so they get retransitioned. */
2796
2797   for (item = ffecom_master_arglist_;
2798        item != NULL;
2799        item = ffebld_trail (item))
2800     {
2801       ffebld arg;
2802       ffesymbol s;
2803
2804       arg = ffebld_head (item);
2805       if (ffebld_op (arg) != FFEBLD_opSYMTER)
2806         continue;               /* Alternate return or some such thing. */
2807       s = ffebld_symter (arg);
2808       ffesymbol_hook (s).decl_tree = NULL_TREE;
2809       ffesymbol_hook (s).length_tree = NULL_TREE;
2810     }
2811
2812   /* Build dummy arg list for this entry point. */
2813
2814   if (charfunc || cmplxfunc)
2815     {                           /* Prepend arg for where result goes. */
2816       tree type;
2817       tree length;
2818
2819       if (charfunc)
2820         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
2821       else
2822         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
2823
2824       result = ffecom_get_invented_identifier ("__g77_%s", "result");
2825
2826       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
2827
2828       if (charfunc)
2829         length = ffecom_char_enhance_arg_ (&type, fn);
2830       else
2831         length = NULL_TREE;     /* Not ref'd if !charfunc. */
2832
2833       type = build_pointer_type (type);
2834       result = build_decl (PARM_DECL, result, type);
2835
2836       push_parm_decl (result);
2837       ffecom_func_result_ = result;
2838
2839       if (charfunc)
2840         {
2841           push_parm_decl (length);
2842           ffecom_func_length_ = length;
2843         }
2844     }
2845   else
2846     result = DECL_RESULT (current_function_decl);
2847
2848   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn), FALSE);
2849
2850   store_parm_decls (0);
2851
2852   ffecom_start_compstmt ();
2853   /* Disallow temp vars at this level.  */
2854   current_binding_level->prep_state = 2;
2855
2856   /* Make local var to hold return type for multi-type master fn. */
2857
2858   if (multi)
2859     {
2860       multi_retval = ffecom_get_invented_identifier ("__g77_%s",
2861                                                      "multi_retval");
2862       multi_retval = build_decl (VAR_DECL, multi_retval,
2863                                  ffecom_multi_type_node_);
2864       multi_retval = start_decl (multi_retval, FALSE);
2865       finish_decl (multi_retval, NULL_TREE, FALSE);
2866     }
2867   else
2868     multi_retval = NULL_TREE;   /* Not actually ref'd if !multi. */
2869
2870   /* Here we emit the actual code for the entry point. */
2871
2872   {
2873     ffebld list;
2874     ffebld arg;
2875     ffesymbol s;
2876     tree arglist = NULL_TREE;
2877     tree *plist = &arglist;
2878     tree prepend;
2879     tree call;
2880     tree actarg;
2881     tree master_fn;
2882
2883     /* Prepare actual arg list based on master arg list. */
2884
2885     for (list = ffecom_master_arglist_;
2886          list != NULL;
2887          list = ffebld_trail (list))
2888       {
2889         arg = ffebld_head (list);
2890         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2891           continue;
2892         s = ffebld_symter (arg);
2893         if (ffesymbol_hook (s).decl_tree == NULL_TREE
2894             || ffesymbol_hook (s).decl_tree == error_mark_node)
2895           actarg = null_pointer_node;   /* We don't have this arg. */
2896         else
2897           actarg = ffesymbol_hook (s).decl_tree;
2898         *plist = build_tree_list (NULL_TREE, actarg);
2899         plist = &TREE_CHAIN (*plist);
2900       }
2901
2902     /* This code appends the length arguments for character
2903        variables/arrays.  */
2904
2905     for (list = ffecom_master_arglist_;
2906          list != NULL;
2907          list = ffebld_trail (list))
2908       {
2909         arg = ffebld_head (list);
2910         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2911           continue;
2912         s = ffebld_symter (arg);
2913         if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
2914           continue;             /* Only looking for CHARACTER arguments. */
2915         if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
2916           continue;             /* Only looking for variables and arrays. */
2917         if (ffesymbol_hook (s).length_tree == NULL_TREE
2918             || ffesymbol_hook (s).length_tree == error_mark_node)
2919           actarg = ffecom_f2c_ftnlen_zero_node; /* We don't have this arg. */
2920         else
2921           actarg = ffesymbol_hook (s).length_tree;
2922         *plist = build_tree_list (NULL_TREE, actarg);
2923         plist = &TREE_CHAIN (*plist);
2924       }
2925
2926     /* Prepend character-value return info to actual arg list. */
2927
2928     if (charfunc)
2929       {
2930         prepend = build_tree_list (NULL_TREE, ffecom_func_result_);
2931         TREE_CHAIN (prepend)
2932           = build_tree_list (NULL_TREE, ffecom_func_length_);
2933         TREE_CHAIN (TREE_CHAIN (prepend)) = arglist;
2934         arglist = prepend;
2935       }
2936
2937     /* Prepend multi-type return value to actual arg list. */
2938
2939     if (multi)
2940       {
2941         prepend
2942           = build_tree_list (NULL_TREE,
2943                              ffecom_1 (ADDR_EXPR,
2944                               build_pointer_type (TREE_TYPE (multi_retval)),
2945                                        multi_retval));
2946         TREE_CHAIN (prepend) = arglist;
2947         arglist = prepend;
2948       }
2949
2950     /* Prepend my entry-point number to the actual arg list. */
2951
2952     prepend = build_tree_list (NULL_TREE, build_int_2 (entrynum, 0));
2953     TREE_CHAIN (prepend) = arglist;
2954     arglist = prepend;
2955
2956     /* Build the call to the master function. */
2957
2958     master_fn = ffecom_1_fn (ffecom_previous_function_decl_);
2959     call = ffecom_3s (CALL_EXPR,
2960                       TREE_TYPE (TREE_TYPE (TREE_TYPE (master_fn))),
2961                       master_fn, arglist, NULL_TREE);
2962
2963     /* Decide whether the master function is a function or subroutine, and
2964        handle the return value for my entry point. */
2965
2966     if (charfunc || ((ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
2967                      && !altreturning))
2968       {
2969         expand_expr_stmt (call);
2970         expand_null_return ();
2971       }
2972     else if (multi && cmplxfunc)
2973       {
2974         expand_expr_stmt (call);
2975         result
2976           = ffecom_1 (INDIRECT_REF,
2977                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2978                       result);
2979         result = ffecom_modify (NULL_TREE, result,
2980                                 ffecom_2 (COMPONENT_REF, TREE_TYPE (result),
2981                                           multi_retval,
2982                                           ffecom_multi_fields_[bt][kt]));
2983         expand_expr_stmt (result);
2984         expand_null_return ();
2985       }
2986     else if (multi)
2987       {
2988         expand_expr_stmt (call);
2989         result
2990           = ffecom_modify (NULL_TREE, result,
2991                            convert (TREE_TYPE (result),
2992                                     ffecom_2 (COMPONENT_REF,
2993                                               ffecom_tree_type[bt][kt],
2994                                               multi_retval,
2995                                               ffecom_multi_fields_[bt][kt])));
2996         expand_return (result);
2997       }
2998     else if (cmplxfunc)
2999       {
3000         result
3001           = ffecom_1 (INDIRECT_REF,
3002                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
3003                       result);
3004         result = ffecom_modify (NULL_TREE, result, call);
3005         expand_expr_stmt (result);
3006         expand_null_return ();
3007       }
3008     else
3009       {
3010         result = ffecom_modify (NULL_TREE,
3011                                 result,
3012                                 convert (TREE_TYPE (result),
3013                                          call));
3014         expand_return (result);
3015       }
3016   }
3017
3018   ffecom_end_compstmt ();
3019
3020   finish_function (0);
3021
3022   lineno = old_lineno;
3023   input_filename = old_input_filename;
3024
3025   ffecom_doing_entry_ = FALSE;
3026 }
3027
3028 #endif
3029 /* Transform expr into gcc tree with possible destination
3030
3031    Recursive descent on expr while making corresponding tree nodes and
3032    attaching type info and such.  If destination supplied and compatible
3033    with temporary that would be made in certain cases, temporary isn't
3034    made, destination used instead, and dest_used flag set TRUE.  */
3035
3036 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3037 static tree
3038 ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
3039               bool *dest_used, bool assignp, bool widenp)
3040 {
3041   tree item;
3042   tree list;
3043   tree args;
3044   ffeinfoBasictype bt;
3045   ffeinfoKindtype kt;
3046   tree t;
3047   tree dt;                      /* decl_tree for an ffesymbol. */
3048   tree tree_type, tree_type_x;
3049   tree left, right;
3050   ffesymbol s;
3051   enum tree_code code;
3052
3053   assert (expr != NULL);
3054
3055   if (dest_used != NULL)
3056     *dest_used = FALSE;
3057
3058   bt = ffeinfo_basictype (ffebld_info (expr));
3059   kt = ffeinfo_kindtype (ffebld_info (expr));
3060   tree_type = ffecom_tree_type[bt][kt];
3061
3062   /* Widen integral arithmetic as desired while preserving signedness.  */
3063   tree_type_x = NULL_TREE;
3064   if (widenp && tree_type
3065       && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
3066       && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
3067     tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
3068
3069   switch (ffebld_op (expr))
3070     {
3071     case FFEBLD_opACCTER:
3072       {
3073         ffebitCount i;
3074         ffebit bits = ffebld_accter_bits (expr);
3075         ffetargetOffset source_offset = 0;
3076         ffetargetOffset dest_offset = ffebld_accter_pad (expr);
3077         tree purpose;
3078
3079         assert (dest_offset == 0
3080                 || (bt == FFEINFO_basictypeCHARACTER
3081                     && kt == FFEINFO_kindtypeCHARACTER1));
3082
3083         list = item = NULL;
3084         for (;;)
3085           {
3086             ffebldConstantUnion cu;
3087             ffebitCount length;
3088             bool value;
3089             ffebldConstantArray ca = ffebld_accter (expr);
3090
3091             ffebit_test (bits, source_offset, &value, &length);
3092             if (length == 0)
3093               break;
3094
3095             if (value)
3096               {
3097                 for (i = 0; i < length; ++i)
3098                   {
3099                     cu = ffebld_constantarray_get (ca, bt, kt,
3100                                                    source_offset + i);
3101
3102                     t = ffecom_constantunion (&cu, bt, kt, tree_type);
3103
3104                     if (i == 0
3105                         && dest_offset != 0)
3106                       purpose = build_int_2 (dest_offset, 0);
3107                     else
3108                       purpose = NULL_TREE;
3109
3110                     if (list == NULL_TREE)
3111                       list = item = build_tree_list (purpose, t);
3112                     else
3113                       {
3114                         TREE_CHAIN (item) = build_tree_list (purpose, t);
3115                         item = TREE_CHAIN (item);
3116                       }
3117                   }
3118               }
3119             source_offset += length;
3120             dest_offset += length;
3121           }
3122       }
3123
3124       item = build_int_2 ((ffebld_accter_size (expr)
3125                            + ffebld_accter_pad (expr)) - 1, 0);
3126       ffebit_kill (ffebld_accter_bits (expr));
3127       TREE_TYPE (item) = ffecom_integer_type_node;
3128       item
3129         = build_array_type
3130           (tree_type,
3131            build_range_type (ffecom_integer_type_node,
3132                              ffecom_integer_zero_node,
3133                              item));
3134       list = build (CONSTRUCTOR, item, NULL_TREE, list);
3135       TREE_CONSTANT (list) = 1;
3136       TREE_STATIC (list) = 1;
3137       return list;
3138
3139     case FFEBLD_opARRTER:
3140       {
3141         ffetargetOffset i;
3142
3143         list = NULL_TREE;
3144         if (ffebld_arrter_pad (expr) == 0)
3145           item = NULL_TREE;
3146         else
3147           {
3148             assert (bt == FFEINFO_basictypeCHARACTER
3149                     && kt == FFEINFO_kindtypeCHARACTER1);
3150
3151             /* Becomes PURPOSE first time through loop.  */
3152             item = build_int_2 (ffebld_arrter_pad (expr), 0);
3153           }
3154
3155         for (i = 0; i < ffebld_arrter_size (expr); ++i)
3156           {
3157             ffebldConstantUnion cu
3158             = ffebld_constantarray_get (ffebld_arrter (expr), bt, kt, i);
3159
3160             t = ffecom_constantunion (&cu, bt, kt, tree_type);
3161
3162             if (list == NULL_TREE)
3163               /* Assume item is PURPOSE first time through loop.  */
3164               list = item = build_tree_list (item, t);
3165             else
3166               {
3167                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
3168                 item = TREE_CHAIN (item);
3169               }
3170           }
3171       }
3172
3173       item = build_int_2 ((ffebld_arrter_size (expr)
3174                           + ffebld_arrter_pad (expr)) - 1, 0);
3175       TREE_TYPE (item) = ffecom_integer_type_node;
3176       item
3177         = build_array_type
3178           (tree_type,
3179            build_range_type (ffecom_integer_type_node,
3180                              ffecom_integer_zero_node,
3181                              item));
3182       list = build (CONSTRUCTOR, item, NULL_TREE, list);
3183       TREE_CONSTANT (list) = 1;
3184       TREE_STATIC (list) = 1;
3185       return list;
3186
3187     case FFEBLD_opCONTER:
3188       assert (ffebld_conter_pad (expr) == 0);
3189       item
3190         = ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr)),
3191                                 bt, kt, tree_type);
3192       return item;
3193
3194     case FFEBLD_opSYMTER:
3195       if ((ffebld_symter_generic (expr) != FFEINTRIN_genNONE)
3196           || (ffebld_symter_specific (expr) != FFEINTRIN_specNONE))
3197         return ffecom_ptr_to_expr (expr);       /* Same as %REF(intrinsic). */
3198       s = ffebld_symter (expr);
3199       t = ffesymbol_hook (s).decl_tree;
3200
3201       if (assignp)
3202         {                       /* ASSIGN'ed-label expr. */
3203           if (ffe_is_ugly_assign ())
3204             {
3205               /* User explicitly wants ASSIGN'ed variables to be at the same
3206                  memory address as the variables when used in non-ASSIGN
3207                  contexts.  That can make old, arcane, non-standard code
3208                  work, but don't try to do it when a pointer wouldn't fit
3209                  in the normal variable (take other approach, and warn,
3210                  instead).  */
3211
3212               if (t == NULL_TREE)
3213                 {
3214                   s = ffecom_sym_transform_ (s);
3215                   t = ffesymbol_hook (s).decl_tree;
3216                   assert (t != NULL_TREE);
3217                 }
3218
3219               if (t == error_mark_node)
3220                 return t;
3221
3222               if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t)))
3223                   >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
3224                 {
3225                   if (ffesymbol_hook (s).addr)
3226                     t = ffecom_1 (INDIRECT_REF,
3227                                   TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3228                   return t;
3229                 }
3230
3231               if (ffesymbol_hook (s).assign_tree == NULL_TREE)
3232                 {
3233                   ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling",
3234                                     FFEBAD_severityWARNING);
3235                   ffebad_string (ffesymbol_text (s));
3236                   ffebad_here (0, ffesymbol_where_line (s),
3237                                ffesymbol_where_column (s));
3238                   ffebad_finish ();
3239                 }
3240             }
3241
3242           /* Don't use the normal variable's tree for ASSIGN, though mark
3243              it as in the system header (housekeeping).  Use an explicit,
3244              specially created sibling that is known to be wide enough
3245              to hold pointers to labels.  */
3246
3247           if (t != NULL_TREE
3248               && TREE_CODE (t) == VAR_DECL)
3249             DECL_IN_SYSTEM_HEADER (t) = 1;      /* Don't let -Wunused complain. */
3250
3251           t = ffesymbol_hook (s).assign_tree;
3252           if (t == NULL_TREE)
3253             {
3254               s = ffecom_sym_transform_assign_ (s);
3255               t = ffesymbol_hook (s).assign_tree;
3256               assert (t != NULL_TREE);
3257             }
3258         }
3259       else
3260         {
3261           if (t == NULL_TREE)
3262             {
3263               s = ffecom_sym_transform_ (s);
3264               t = ffesymbol_hook (s).decl_tree;
3265               assert (t != NULL_TREE);
3266             }
3267           if (ffesymbol_hook (s).addr)
3268             t = ffecom_1 (INDIRECT_REF,
3269                           TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3270         }
3271       return t;
3272
3273     case FFEBLD_opARRAYREF:
3274       return ffecom_arrayref_ (NULL_TREE, expr, 0);
3275
3276     case FFEBLD_opUPLUS:
3277       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3278       return ffecom_1 (NOP_EXPR, tree_type, left);
3279
3280     case FFEBLD_opPAREN:
3281       /* ~~~Make sure Fortran rules respected here */
3282       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3283       return ffecom_1 (NOP_EXPR, tree_type, left);
3284
3285     case FFEBLD_opUMINUS:
3286       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3287       if (tree_type_x)
3288         {
3289           tree_type = tree_type_x;
3290           left = convert (tree_type, left);
3291         }
3292       return ffecom_1 (NEGATE_EXPR, tree_type, left);
3293
3294     case FFEBLD_opADD:
3295       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3296       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3297       if (tree_type_x)
3298         {
3299           tree_type = tree_type_x;
3300           left = convert (tree_type, left);
3301           right = convert (tree_type, right);
3302         }
3303       return ffecom_2 (PLUS_EXPR, tree_type, left, right);
3304
3305     case FFEBLD_opSUBTRACT:
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 (MINUS_EXPR, tree_type, left, right);
3315
3316     case FFEBLD_opMULTIPLY:
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 (MULT_EXPR, tree_type, left, right);
3326
3327     case FFEBLD_opDIVIDE:
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_tree_divide_ (tree_type, left, right,
3337                                   dest_tree, dest, dest_used,
3338                                   ffebld_nonter_hook (expr));
3339
3340     case FFEBLD_opPOWER:
3341       {
3342         ffebld left = ffebld_left (expr);
3343         ffebld right = ffebld_right (expr);
3344         ffecomGfrt code;
3345         ffeinfoKindtype rtkt;
3346         ffeinfoKindtype ltkt;
3347         bool ref = TRUE;
3348
3349         switch (ffeinfo_basictype (ffebld_info (right)))
3350           {
3351
3352           case FFEINFO_basictypeINTEGER:
3353             if (1 || optimize)
3354               {
3355                 item = ffecom_expr_power_integer_ (expr);
3356                 if (item != NULL_TREE)
3357                   return item;
3358               }
3359
3360             rtkt = FFEINFO_kindtypeINTEGER1;
3361             switch (ffeinfo_basictype (ffebld_info (left)))
3362               {
3363               case FFEINFO_basictypeINTEGER:
3364                 if ((ffeinfo_kindtype (ffebld_info (left))
3365                     == FFEINFO_kindtypeINTEGER4)
3366                     || (ffeinfo_kindtype (ffebld_info (right))
3367                         == FFEINFO_kindtypeINTEGER4))
3368                   {
3369                     code = FFECOM_gfrtPOW_QQ;
3370                     ltkt = FFEINFO_kindtypeINTEGER4;
3371                     rtkt = FFEINFO_kindtypeINTEGER4;
3372                   }
3373                 else
3374                   {
3375                     code = FFECOM_gfrtPOW_II;
3376                     ltkt = FFEINFO_kindtypeINTEGER1;
3377                   }
3378                 break;
3379
3380               case FFEINFO_basictypeREAL:
3381                 if (ffeinfo_kindtype (ffebld_info (left))
3382                     == FFEINFO_kindtypeREAL1)
3383                   {
3384                     code = FFECOM_gfrtPOW_RI;
3385                     ltkt = FFEINFO_kindtypeREAL1;
3386                   }
3387                 else
3388                   {
3389                     code = FFECOM_gfrtPOW_DI;
3390                     ltkt = FFEINFO_kindtypeREAL2;
3391                   }
3392                 break;
3393
3394               case FFEINFO_basictypeCOMPLEX:
3395                 if (ffeinfo_kindtype (ffebld_info (left))
3396                     == FFEINFO_kindtypeREAL1)
3397                   {
3398                     code = FFECOM_gfrtPOW_CI;   /* Overlapping result okay. */
3399                     ltkt = FFEINFO_kindtypeREAL1;
3400                   }
3401                 else
3402                   {
3403                     code = FFECOM_gfrtPOW_ZI;   /* Overlapping result okay. */
3404                     ltkt = FFEINFO_kindtypeREAL2;
3405                   }
3406                 break;
3407
3408               default:
3409                 assert ("bad pow_*i" == NULL);
3410                 code = FFECOM_gfrtPOW_CI;       /* Overlapping result okay. */
3411                 ltkt = FFEINFO_kindtypeREAL1;
3412                 break;
3413               }
3414             if (ffeinfo_kindtype (ffebld_info (left)) != ltkt)
3415               left = ffeexpr_convert (left, NULL, NULL,
3416                                       ffeinfo_basictype (ffebld_info (left)),
3417                                       ltkt, 0,
3418                                       FFETARGET_charactersizeNONE,
3419                                       FFEEXPR_contextLET);
3420             if (ffeinfo_kindtype (ffebld_info (right)) != rtkt)
3421               right = ffeexpr_convert (right, NULL, NULL,
3422                                        FFEINFO_basictypeINTEGER,
3423                                        rtkt, 0,
3424                                        FFETARGET_charactersizeNONE,
3425                                        FFEEXPR_contextLET);
3426             break;
3427
3428           case FFEINFO_basictypeREAL:
3429             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3430               left = ffeexpr_convert (left, NULL, NULL, FFEINFO_basictypeREAL,
3431                                       FFEINFO_kindtypeREALDOUBLE, 0,
3432                                       FFETARGET_charactersizeNONE,
3433                                       FFEEXPR_contextLET);
3434             if (ffeinfo_kindtype (ffebld_info (right))
3435                 == FFEINFO_kindtypeREAL1)
3436               right = ffeexpr_convert (right, NULL, NULL,
3437                                        FFEINFO_basictypeREAL,
3438                                        FFEINFO_kindtypeREALDOUBLE, 0,
3439                                        FFETARGET_charactersizeNONE,
3440                                        FFEEXPR_contextLET);
3441             /* We used to call FFECOM_gfrtPOW_DD here,
3442                which passes arguments by reference.  */
3443             code = FFECOM_gfrtL_POW;
3444             /* Pass arguments by value. */
3445             ref  = FALSE;
3446             break;
3447
3448           case FFEINFO_basictypeCOMPLEX:
3449             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3450               left = ffeexpr_convert (left, NULL, NULL,
3451                                       FFEINFO_basictypeCOMPLEX,
3452                                       FFEINFO_kindtypeREALDOUBLE, 0,
3453                                       FFETARGET_charactersizeNONE,
3454                                       FFEEXPR_contextLET);
3455             if (ffeinfo_kindtype (ffebld_info (right))
3456                 == FFEINFO_kindtypeREAL1)
3457               right = ffeexpr_convert (right, NULL, NULL,
3458                                        FFEINFO_basictypeCOMPLEX,
3459                                        FFEINFO_kindtypeREALDOUBLE, 0,
3460                                        FFETARGET_charactersizeNONE,
3461                                        FFEEXPR_contextLET);
3462             code = FFECOM_gfrtPOW_ZZ;   /* Overlapping result okay. */
3463             ref = TRUE;                 /* Pass arguments by reference. */
3464             break;
3465
3466           default:
3467             assert ("bad pow_x*" == NULL);
3468             code = FFECOM_gfrtPOW_II;
3469             break;
3470           }
3471         return ffecom_call_binop_ (ffecom_gfrt_tree_ (code),
3472                                    ffecom_gfrt_kindtype (code),
3473                                    (ffe_is_f2c_library ()
3474                                     && ffecom_gfrt_complex_[code]),
3475                                    tree_type, left, right,
3476                                    dest_tree, dest, dest_used,
3477                                    NULL_TREE, FALSE, ref,
3478                                    ffebld_nonter_hook (expr));
3479       }
3480
3481     case FFEBLD_opNOT:
3482       switch (bt)
3483         {
3484         case FFEINFO_basictypeLOGICAL:
3485           item = ffecom_truth_value_invert (ffecom_expr (ffebld_left (expr)));
3486           return convert (tree_type, item);
3487
3488         case FFEINFO_basictypeINTEGER:
3489           return ffecom_1 (BIT_NOT_EXPR, tree_type,
3490                            ffecom_expr (ffebld_left (expr)));
3491
3492         default:
3493           assert ("NOT bad basictype" == NULL);
3494           /* Fall through. */
3495         case FFEINFO_basictypeANY:
3496           return error_mark_node;
3497         }
3498       break;
3499
3500     case FFEBLD_opFUNCREF:
3501       assert (ffeinfo_basictype (ffebld_info (expr))
3502               != FFEINFO_basictypeCHARACTER);
3503       /* Fall through.   */
3504     case FFEBLD_opSUBRREF:
3505       if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
3506           == FFEINFO_whereINTRINSIC)
3507         {                       /* Invocation of an intrinsic. */
3508           item = ffecom_expr_intrinsic_ (expr, dest_tree, dest,
3509                                          dest_used);
3510           return item;
3511         }
3512       s = ffebld_symter (ffebld_left (expr));
3513       dt = ffesymbol_hook (s).decl_tree;
3514       if (dt == NULL_TREE)
3515         {
3516           s = ffecom_sym_transform_ (s);
3517           dt = ffesymbol_hook (s).decl_tree;
3518         }
3519       if (dt == error_mark_node)
3520         return dt;
3521
3522       if (ffesymbol_hook (s).addr)
3523         item = dt;
3524       else
3525         item = ffecom_1_fn (dt);
3526
3527       if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
3528         args = ffecom_list_expr (ffebld_right (expr));
3529       else
3530         args = ffecom_list_ptr_to_expr (ffebld_right (expr));
3531
3532       if (args == error_mark_node)
3533         return error_mark_node;
3534
3535       item = ffecom_call_ (item, kt,
3536                            ffesymbol_is_f2c (s)
3537                            && (bt == FFEINFO_basictypeCOMPLEX)
3538                            && (ffesymbol_where (s)
3539                                != FFEINFO_whereCONSTANT),
3540                            tree_type,
3541                            args,
3542                            dest_tree, dest, dest_used,
3543                            error_mark_node, FALSE,
3544                            ffebld_nonter_hook (expr));
3545       TREE_SIDE_EFFECTS (item) = 1;
3546       return item;
3547
3548     case FFEBLD_opAND:
3549       switch (bt)
3550         {
3551         case FFEINFO_basictypeLOGICAL:
3552           item
3553             = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3554                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3555                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3556           return convert (tree_type, item);
3557
3558         case FFEINFO_basictypeINTEGER:
3559           return ffecom_2 (BIT_AND_EXPR, tree_type,
3560                            ffecom_expr (ffebld_left (expr)),
3561                            ffecom_expr (ffebld_right (expr)));
3562
3563         default:
3564           assert ("AND bad basictype" == NULL);
3565           /* Fall through. */
3566         case FFEINFO_basictypeANY:
3567           return error_mark_node;
3568         }
3569       break;
3570
3571     case FFEBLD_opOR:
3572       switch (bt)
3573         {
3574         case FFEINFO_basictypeLOGICAL:
3575           item
3576             = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
3577                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3578                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3579           return convert (tree_type, item);
3580
3581         case FFEINFO_basictypeINTEGER:
3582           return ffecom_2 (BIT_IOR_EXPR, tree_type,
3583                            ffecom_expr (ffebld_left (expr)),
3584                            ffecom_expr (ffebld_right (expr)));
3585
3586         default:
3587           assert ("OR bad basictype" == NULL);
3588           /* Fall through. */
3589         case FFEINFO_basictypeANY:
3590           return error_mark_node;
3591         }
3592       break;
3593
3594     case FFEBLD_opXOR:
3595     case FFEBLD_opNEQV:
3596       switch (bt)
3597         {
3598         case FFEINFO_basictypeLOGICAL:
3599           item
3600             = ffecom_2 (NE_EXPR, integer_type_node,
3601                         ffecom_expr (ffebld_left (expr)),
3602                         ffecom_expr (ffebld_right (expr)));
3603           return convert (tree_type, ffecom_truth_value (item));
3604
3605         case FFEINFO_basictypeINTEGER:
3606           return ffecom_2 (BIT_XOR_EXPR, tree_type,
3607                            ffecom_expr (ffebld_left (expr)),
3608                            ffecom_expr (ffebld_right (expr)));
3609
3610         default:
3611           assert ("XOR/NEQV bad basictype" == NULL);
3612           /* Fall through. */
3613         case FFEINFO_basictypeANY:
3614           return error_mark_node;
3615         }
3616       break;
3617
3618     case FFEBLD_opEQV:
3619       switch (bt)
3620         {
3621         case FFEINFO_basictypeLOGICAL:
3622           item
3623             = ffecom_2 (EQ_EXPR, integer_type_node,
3624                         ffecom_expr (ffebld_left (expr)),
3625                         ffecom_expr (ffebld_right (expr)));
3626           return convert (tree_type, ffecom_truth_value (item));
3627
3628         case FFEINFO_basictypeINTEGER:
3629           return
3630             ffecom_1 (BIT_NOT_EXPR, tree_type,
3631                       ffecom_2 (BIT_XOR_EXPR, tree_type,
3632                                 ffecom_expr (ffebld_left (expr)),
3633                                 ffecom_expr (ffebld_right (expr))));
3634
3635         default:
3636           assert ("EQV bad basictype" == NULL);
3637           /* Fall through. */
3638         case FFEINFO_basictypeANY:
3639           return error_mark_node;
3640         }
3641       break;
3642
3643     case FFEBLD_opCONVERT:
3644       if (ffebld_op (ffebld_left (expr)) == FFEBLD_opANY)
3645         return error_mark_node;
3646
3647       switch (bt)
3648         {
3649         case FFEINFO_basictypeLOGICAL:
3650         case FFEINFO_basictypeINTEGER:
3651         case FFEINFO_basictypeREAL:
3652           return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3653
3654         case FFEINFO_basictypeCOMPLEX:
3655           switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3656             {
3657             case FFEINFO_basictypeINTEGER:
3658             case FFEINFO_basictypeLOGICAL:
3659             case FFEINFO_basictypeREAL:
3660               item = ffecom_expr (ffebld_left (expr));
3661               if (item == error_mark_node)
3662                 return error_mark_node;
3663               /* convert() takes care of converting to the subtype first,
3664                  at least in gcc-2.7.2. */
3665               item = convert (tree_type, item);
3666               return item;
3667
3668             case FFEINFO_basictypeCOMPLEX:
3669               return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3670
3671             default:
3672               assert ("CONVERT COMPLEX bad basictype" == NULL);
3673               /* Fall through. */
3674             case FFEINFO_basictypeANY:
3675               return error_mark_node;
3676             }
3677           break;
3678
3679         default:
3680           assert ("CONVERT bad basictype" == NULL);
3681           /* Fall through. */
3682         case FFEINFO_basictypeANY:
3683           return error_mark_node;
3684         }
3685       break;
3686
3687     case FFEBLD_opLT:
3688       code = LT_EXPR;
3689       goto relational;          /* :::::::::::::::::::: */
3690
3691     case FFEBLD_opLE:
3692       code = LE_EXPR;
3693       goto relational;          /* :::::::::::::::::::: */
3694
3695     case FFEBLD_opEQ:
3696       code = EQ_EXPR;
3697       goto relational;          /* :::::::::::::::::::: */
3698
3699     case FFEBLD_opNE:
3700       code = NE_EXPR;
3701       goto relational;          /* :::::::::::::::::::: */
3702
3703     case FFEBLD_opGT:
3704       code = GT_EXPR;
3705       goto relational;          /* :::::::::::::::::::: */
3706
3707     case FFEBLD_opGE:
3708       code = GE_EXPR;
3709
3710     relational:         /* :::::::::::::::::::: */
3711       switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3712         {
3713         case FFEINFO_basictypeLOGICAL:
3714         case FFEINFO_basictypeINTEGER:
3715         case FFEINFO_basictypeREAL:
3716           item = ffecom_2 (code, integer_type_node,
3717                            ffecom_expr (ffebld_left (expr)),
3718                            ffecom_expr (ffebld_right (expr)));
3719           return convert (tree_type, item);
3720
3721         case FFEINFO_basictypeCOMPLEX:
3722           assert (code == EQ_EXPR || code == NE_EXPR);
3723           {
3724             tree real_type;
3725             tree arg1 = ffecom_expr (ffebld_left (expr));
3726             tree arg2 = ffecom_expr (ffebld_right (expr));
3727
3728             if (arg1 == error_mark_node || arg2 == error_mark_node)
3729               return error_mark_node;
3730
3731             arg1 = ffecom_save_tree (arg1);
3732             arg2 = ffecom_save_tree (arg2);
3733
3734             if (TREE_CODE (TREE_TYPE (arg1)) == COMPLEX_TYPE)
3735               {
3736                 real_type = TREE_TYPE (TREE_TYPE (arg1));
3737                 assert (real_type == TREE_TYPE (TREE_TYPE (arg2)));
3738               }
3739             else
3740               {
3741                 real_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg1)));
3742                 assert (real_type == TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg2))));
3743               }
3744
3745             item
3746               = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3747                           ffecom_2 (EQ_EXPR, integer_type_node,
3748                                   ffecom_1 (REALPART_EXPR, real_type, arg1),
3749                                  ffecom_1 (REALPART_EXPR, real_type, arg2)),
3750                           ffecom_2 (EQ_EXPR, integer_type_node,
3751                                   ffecom_1 (IMAGPART_EXPR, real_type, arg1),
3752                                     ffecom_1 (IMAGPART_EXPR, real_type,
3753                                               arg2)));
3754             if (code == EQ_EXPR)
3755               item = ffecom_truth_value (item);
3756             else
3757               item = ffecom_truth_value_invert (item);
3758             return convert (tree_type, item);
3759           }
3760
3761         case FFEINFO_basictypeCHARACTER:
3762           {
3763             ffebld left = ffebld_left (expr);
3764             ffebld right = ffebld_right (expr);
3765             tree left_tree;
3766             tree right_tree;
3767             tree left_length;
3768             tree right_length;
3769
3770             /* f2c run-time functions do the implicit blank-padding for us,
3771                so we don't usually have to implement blank-padding ourselves.
3772                (The exception is when we pass an argument to a separately
3773                compiled statement function -- if we know the arg is not the
3774                same length as the dummy, we must truncate or extend it.  If
3775                we "inline" statement functions, that necessity goes away as
3776                well.)
3777
3778                Strip off the CONVERT operators that blank-pad.  (Truncation by
3779                CONVERT shouldn't happen here, but it can happen in
3780                assignments.) */
3781
3782             while (ffebld_op (left) == FFEBLD_opCONVERT)
3783               left = ffebld_left (left);
3784             while (ffebld_op (right) == FFEBLD_opCONVERT)
3785               right = ffebld_left (right);
3786
3787             left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
3788             right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
3789
3790             if (left_tree == error_mark_node || left_length == error_mark_node
3791                 || right_tree == error_mark_node
3792                 || right_length == error_mark_node)
3793               return error_mark_node;
3794
3795             if ((ffebld_size_known (left) == 1)
3796                 && (ffebld_size_known (right) == 1))
3797               {
3798                 left_tree
3799                   = ffecom_1 (INDIRECT_REF,
3800                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3801                               left_tree);
3802                 right_tree
3803                   = ffecom_1 (INDIRECT_REF,
3804                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3805                               right_tree);
3806
3807                 item
3808                   = ffecom_2 (code, integer_type_node,
3809                               ffecom_2 (ARRAY_REF,
3810                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3811                                         left_tree,
3812                                         integer_one_node),
3813                               ffecom_2 (ARRAY_REF,
3814                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3815                                         right_tree,
3816                                         integer_one_node));
3817               }
3818             else
3819               {
3820                 item = build_tree_list (NULL_TREE, left_tree);
3821                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, right_tree);
3822                 TREE_CHAIN (TREE_CHAIN (item)) = build_tree_list (NULL_TREE,
3823                                                                left_length);
3824                 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
3825                   = build_tree_list (NULL_TREE, right_length);
3826                 item = ffecom_call_gfrt (FFECOM_gfrtCMP, item, NULL_TREE);
3827                 item = ffecom_2 (code, integer_type_node,
3828                                  item,
3829                                  convert (TREE_TYPE (item),
3830                                           integer_zero_node));
3831               }
3832             item = convert (tree_type, item);
3833           }
3834
3835           return item;
3836
3837         default:
3838           assert ("relational bad basictype" == NULL);
3839           /* Fall through. */
3840         case FFEINFO_basictypeANY:
3841           return error_mark_node;
3842         }
3843       break;
3844
3845     case FFEBLD_opPERCENT_LOC:
3846       item = ffecom_arg_ptr_to_expr (ffebld_left (expr), &list);
3847       return convert (tree_type, item);
3848
3849     case FFEBLD_opITEM:
3850     case FFEBLD_opSTAR:
3851     case FFEBLD_opBOUNDS:
3852     case FFEBLD_opREPEAT:
3853     case FFEBLD_opLABTER:
3854     case FFEBLD_opLABTOK:
3855     case FFEBLD_opIMPDO:
3856     case FFEBLD_opCONCATENATE:
3857     case FFEBLD_opSUBSTR:
3858     default:
3859       assert ("bad op" == NULL);
3860       /* Fall through. */
3861     case FFEBLD_opANY:
3862       return error_mark_node;
3863     }
3864
3865 #if 1
3866   assert ("didn't think anything got here anymore!!" == NULL);
3867 #else
3868   switch (ffebld_arity (expr))
3869     {
3870     case 2:
3871       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3872       TREE_OPERAND (item, 1) = ffecom_expr (ffebld_right (expr));
3873       if (TREE_OPERAND (item, 0) == error_mark_node
3874           || TREE_OPERAND (item, 1) == error_mark_node)
3875         return error_mark_node;
3876       break;
3877
3878     case 1:
3879       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3880       if (TREE_OPERAND (item, 0) == error_mark_node)
3881         return error_mark_node;
3882       break;
3883
3884     default:
3885       break;
3886     }
3887
3888   return fold (item);
3889 #endif
3890 }
3891
3892 #endif
3893 /* Returns the tree that does the intrinsic invocation.
3894
3895    Note: this function applies only to intrinsics returning
3896    CHARACTER*1 or non-CHARACTER results, and to intrinsic
3897    subroutines.  */
3898
3899 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3900 static tree
3901 ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
3902                         ffebld dest, bool *dest_used)
3903 {
3904   tree expr_tree;
3905   tree saved_expr1;             /* For those who need it. */
3906   tree saved_expr2;             /* For those who need it. */
3907   ffeinfoBasictype bt;
3908   ffeinfoKindtype kt;
3909   tree tree_type;
3910   tree arg1_type;
3911   tree real_type;               /* REAL type corresponding to COMPLEX. */
3912   tree tempvar;
3913   ffebld list = ffebld_right (expr);    /* List of (some) args. */
3914   ffebld arg1;                  /* For handy reference. */
3915   ffebld arg2;
3916   ffebld arg3;
3917   ffeintrinImp codegen_imp;
3918   ffecomGfrt gfrt;
3919
3920   assert (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER);
3921
3922   if (dest_used != NULL)
3923     *dest_used = FALSE;
3924
3925   bt = ffeinfo_basictype (ffebld_info (expr));
3926   kt = ffeinfo_kindtype (ffebld_info (expr));
3927   tree_type = ffecom_tree_type[bt][kt];
3928
3929   if (list != NULL)
3930     {
3931       arg1 = ffebld_head (list);
3932       if (arg1 != NULL && ffebld_op (arg1) == FFEBLD_opANY)
3933         return error_mark_node;
3934       if ((list = ffebld_trail (list)) != NULL)
3935         {
3936           arg2 = ffebld_head (list);
3937           if (arg2 != NULL && ffebld_op (arg2) == FFEBLD_opANY)
3938             return error_mark_node;
3939           if ((list = ffebld_trail (list)) != NULL)
3940             {
3941               arg3 = ffebld_head (list);
3942               if (arg3 != NULL && ffebld_op (arg3) == FFEBLD_opANY)
3943                 return error_mark_node;
3944             }
3945           else
3946             arg3 = NULL;
3947         }
3948       else
3949         arg2 = arg3 = NULL;
3950     }
3951   else
3952     arg1 = arg2 = arg3 = NULL;
3953
3954   /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
3955      args.  This is used by the MAX/MIN expansions. */
3956
3957   if (arg1 != NULL)
3958     arg1_type = ffecom_tree_type
3959       [ffeinfo_basictype (ffebld_info (arg1))]
3960       [ffeinfo_kindtype (ffebld_info (arg1))];
3961   else
3962     arg1_type = NULL_TREE;      /* Really not needed, but might catch bugs
3963                                    here. */
3964
3965   /* There are several ways for each of the cases in the following switch
3966      statements to exit (from simplest to use to most complicated):
3967
3968      break;  (when expr_tree == NULL)
3969
3970      A standard call is made to the specific intrinsic just as if it had been
3971      passed in as a dummy procedure and called as any old procedure.  This
3972      method can produce slower code but in some cases it's the easiest way for
3973      now.  However, if a (presumably faster) direct call is available,
3974      that is used, so this is the easiest way in many more cases now.
3975
3976      gfrt = FFECOM_gfrtWHATEVER;
3977      break;
3978
3979      gfrt contains the gfrt index of a library function to call, passing the
3980      argument(s) by value rather than by reference.  Used when a more
3981      careful choice of library function is needed than that provided
3982      by the vanilla `break;'.
3983
3984      return expr_tree;
3985
3986      The expr_tree has been completely set up and is ready to be returned
3987      as is.  No further actions are taken.  Use this when the tree is not
3988      in the simple form for one of the arity_n labels.   */
3989
3990   /* For info on how the switch statement cases were written, see the files
3991      enclosed in comments below the switch statement. */
3992
3993   codegen_imp = ffebld_symter_implementation (ffebld_left (expr));
3994   gfrt = ffeintrin_gfrt_direct (codegen_imp);
3995   if (gfrt == FFECOM_gfrt)
3996     gfrt = ffeintrin_gfrt_indirect (codegen_imp);
3997
3998   switch (codegen_imp)
3999     {
4000     case FFEINTRIN_impABS:
4001     case FFEINTRIN_impCABS:
4002     case FFEINTRIN_impCDABS:
4003     case FFEINTRIN_impDABS:
4004     case FFEINTRIN_impIABS:
4005       if (ffeinfo_basictype (ffebld_info (arg1))
4006           == FFEINFO_basictypeCOMPLEX)
4007         {
4008           if (kt == FFEINFO_kindtypeREAL1)
4009             gfrt = FFECOM_gfrtCABS;
4010           else if (kt == FFEINFO_kindtypeREAL2)
4011             gfrt = FFECOM_gfrtCDABS;
4012           break;
4013         }
4014       return ffecom_1 (ABS_EXPR, tree_type,
4015                        convert (tree_type, ffecom_expr (arg1)));
4016
4017     case FFEINTRIN_impACOS:
4018     case FFEINTRIN_impDACOS:
4019       break;
4020
4021     case FFEINTRIN_impAIMAG:
4022     case FFEINTRIN_impDIMAG:
4023     case FFEINTRIN_impIMAGPART:
4024       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
4025         arg1_type = TREE_TYPE (arg1_type);
4026       else
4027         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
4028
4029       return
4030         convert (tree_type,
4031                  ffecom_1 (IMAGPART_EXPR, arg1_type,
4032                            ffecom_expr (arg1)));
4033
4034     case FFEINTRIN_impAINT:
4035     case FFEINTRIN_impDINT:
4036 #if 0
4037       /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg.  */
4038       return ffecom_1 (FIX_TRUNC_EXPR, tree_type, ffecom_expr (arg1));
4039 #else /* in the meantime, must use floor to avoid range problems with ints */
4040       /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
4041       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4042       return
4043         convert (tree_type,
4044                  ffecom_3 (COND_EXPR, double_type_node,
4045                            ffecom_truth_value
4046                            (ffecom_2 (GE_EXPR, integer_type_node,
4047                                       saved_expr1,
4048                                       convert (arg1_type,
4049                                                ffecom_float_zero_))),
4050                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4051                                              build_tree_list (NULL_TREE,
4052                                                   convert (double_type_node,
4053                                                            saved_expr1)),
4054                                              NULL_TREE),
4055                            ffecom_1 (NEGATE_EXPR, double_type_node,
4056                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4057                                                  build_tree_list (NULL_TREE,
4058                                                   convert (double_type_node,
4059                                                       ffecom_1 (NEGATE_EXPR,
4060                                                                 arg1_type,
4061                                                                saved_expr1))),
4062                                                        NULL_TREE)
4063                                      ))
4064                  );
4065 #endif
4066
4067     case FFEINTRIN_impANINT:
4068     case FFEINTRIN_impDNINT:
4069 #if 0                           /* This way of doing it won't handle real
4070                                    numbers of large magnitudes. */
4071       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4072       expr_tree = convert (tree_type,
4073                            convert (integer_type_node,
4074                                     ffecom_3 (COND_EXPR, tree_type,
4075                                               ffecom_truth_value
4076                                               (ffecom_2 (GE_EXPR,
4077                                                          integer_type_node,
4078                                                          saved_expr1,
4079                                                        ffecom_float_zero_)),
4080                                               ffecom_2 (PLUS_EXPR,
4081                                                         tree_type,
4082                                                         saved_expr1,
4083                                                         ffecom_float_half_),
4084                                               ffecom_2 (MINUS_EXPR,
4085                                                         tree_type,
4086                                                         saved_expr1,
4087                                                      ffecom_float_half_))));
4088       return expr_tree;
4089 #else /* So we instead call floor. */
4090       /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
4091       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4092       return
4093         convert (tree_type,
4094                  ffecom_3 (COND_EXPR, double_type_node,
4095                            ffecom_truth_value
4096                            (ffecom_2 (GE_EXPR, integer_type_node,
4097                                       saved_expr1,
4098                                       convert (arg1_type,
4099                                                ffecom_float_zero_))),
4100                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4101                                              build_tree_list (NULL_TREE,
4102                                                   convert (double_type_node,
4103                                                            ffecom_2 (PLUS_EXPR,
4104                                                                      arg1_type,
4105                                                                      saved_expr1,
4106                                                                      convert (arg1_type,
4107                                                                               ffecom_float_half_)))),
4108                                              NULL_TREE),
4109                            ffecom_1 (NEGATE_EXPR, double_type_node,
4110                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4111                                                        build_tree_list (NULL_TREE,
4112                                                                         convert (double_type_node,
4113                                                                                  ffecom_2 (MINUS_EXPR,
4114                                                                                            arg1_type,
4115                                                                                            convert (arg1_type,
4116                                                                                                     ffecom_float_half_),
4117                                                                                            saved_expr1))),
4118                                                        NULL_TREE))
4119                            )
4120                  );
4121 #endif
4122
4123     case FFEINTRIN_impASIN:
4124     case FFEINTRIN_impDASIN:
4125     case FFEINTRIN_impATAN:
4126     case FFEINTRIN_impDATAN:
4127     case FFEINTRIN_impATAN2:
4128     case FFEINTRIN_impDATAN2:
4129       break;
4130
4131     case FFEINTRIN_impCHAR:
4132     case FFEINTRIN_impACHAR:
4133 #ifdef HOHO
4134       tempvar = ffecom_make_tempvar (char_type_node, 1, -1);
4135 #else
4136       tempvar = ffebld_nonter_hook (expr);
4137       assert (tempvar);
4138 #endif
4139       {
4140         tree tmv = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar)));
4141
4142         expr_tree = ffecom_modify (tmv,
4143                                    ffecom_2 (ARRAY_REF, tmv, tempvar,
4144                                              integer_one_node),
4145                                    convert (tmv, ffecom_expr (arg1)));
4146       }
4147       expr_tree = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar),
4148                             expr_tree,
4149                             tempvar);
4150       expr_tree = ffecom_1 (ADDR_EXPR,
4151                             build_pointer_type (TREE_TYPE (expr_tree)),
4152                             expr_tree);
4153       return expr_tree;
4154
4155     case FFEINTRIN_impCMPLX:
4156     case FFEINTRIN_impDCMPLX:
4157       if (arg2 == NULL)
4158         return
4159           convert (tree_type, ffecom_expr (arg1));
4160
4161       real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4162       return
4163         ffecom_2 (COMPLEX_EXPR, tree_type,
4164                   convert (real_type, ffecom_expr (arg1)),
4165                   convert (real_type,
4166                            ffecom_expr (arg2)));
4167
4168     case FFEINTRIN_impCOMPLEX:
4169       return
4170         ffecom_2 (COMPLEX_EXPR, tree_type,
4171                   ffecom_expr (arg1),
4172                   ffecom_expr (arg2));
4173
4174     case FFEINTRIN_impCONJG:
4175     case FFEINTRIN_impDCONJG:
4176       {
4177         tree arg1_tree;
4178
4179         real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4180         arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4181         return
4182           ffecom_2 (COMPLEX_EXPR, tree_type,
4183                     ffecom_1 (REALPART_EXPR, real_type, arg1_tree),
4184                     ffecom_1 (NEGATE_EXPR, real_type,
4185                               ffecom_1 (IMAGPART_EXPR, real_type, arg1_tree)));
4186       }
4187
4188     case FFEINTRIN_impCOS:
4189     case FFEINTRIN_impCCOS:
4190     case FFEINTRIN_impCDCOS:
4191     case FFEINTRIN_impDCOS:
4192       if (bt == FFEINFO_basictypeCOMPLEX)
4193         {
4194           if (kt == FFEINFO_kindtypeREAL1)
4195             gfrt = FFECOM_gfrtCCOS;     /* Overlapping result okay. */
4196           else if (kt == FFEINFO_kindtypeREAL2)
4197             gfrt = FFECOM_gfrtCDCOS;    /* Overlapping result okay. */
4198         }
4199       break;
4200
4201     case FFEINTRIN_impCOSH:
4202     case FFEINTRIN_impDCOSH:
4203       break;
4204
4205     case FFEINTRIN_impDBLE:
4206     case FFEINTRIN_impDFLOAT:
4207     case FFEINTRIN_impDREAL:
4208     case FFEINTRIN_impFLOAT:
4209     case FFEINTRIN_impIDINT:
4210     case FFEINTRIN_impIFIX:
4211     case FFEINTRIN_impINT2:
4212     case FFEINTRIN_impINT8:
4213     case FFEINTRIN_impINT:
4214     case FFEINTRIN_impLONG:
4215     case FFEINTRIN_impREAL:
4216     case FFEINTRIN_impSHORT:
4217     case FFEINTRIN_impSNGL:
4218       return convert (tree_type, ffecom_expr (arg1));
4219
4220     case FFEINTRIN_impDIM:
4221     case FFEINTRIN_impDDIM:
4222     case FFEINTRIN_impIDIM:
4223       saved_expr1 = ffecom_save_tree (convert (tree_type,
4224                                                ffecom_expr (arg1)));
4225       saved_expr2 = ffecom_save_tree (convert (tree_type,
4226                                                ffecom_expr (arg2)));
4227       return
4228         ffecom_3 (COND_EXPR, tree_type,
4229                   ffecom_truth_value
4230                   (ffecom_2 (GT_EXPR, integer_type_node,
4231                              saved_expr1,
4232                              saved_expr2)),
4233                   ffecom_2 (MINUS_EXPR, tree_type,
4234                             saved_expr1,
4235                             saved_expr2),
4236                   convert (tree_type, ffecom_float_zero_));
4237
4238     case FFEINTRIN_impDPROD:
4239       return
4240         ffecom_2 (MULT_EXPR, tree_type,
4241                   convert (tree_type, ffecom_expr (arg1)),
4242                   convert (tree_type, ffecom_expr (arg2)));
4243
4244     case FFEINTRIN_impEXP:
4245     case FFEINTRIN_impCDEXP:
4246     case FFEINTRIN_impCEXP:
4247     case FFEINTRIN_impDEXP:
4248       if (bt == FFEINFO_basictypeCOMPLEX)
4249         {
4250           if (kt == FFEINFO_kindtypeREAL1)
4251             gfrt = FFECOM_gfrtCEXP;     /* Overlapping result okay. */
4252           else if (kt == FFEINFO_kindtypeREAL2)
4253             gfrt = FFECOM_gfrtCDEXP;    /* Overlapping result okay. */
4254         }
4255       break;
4256
4257     case FFEINTRIN_impICHAR:
4258     case FFEINTRIN_impIACHAR:
4259 #if 0                           /* The simple approach. */
4260       ffecom_char_args_ (&expr_tree, &saved_expr1 /* Ignored */ , arg1);
4261       expr_tree
4262         = ffecom_1 (INDIRECT_REF,
4263                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4264                     expr_tree);
4265       expr_tree
4266         = ffecom_2 (ARRAY_REF,
4267                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4268                     expr_tree,
4269                     integer_one_node);
4270       return convert (tree_type, expr_tree);
4271 #else /* The more interesting (and more optimal) approach. */
4272       expr_tree = ffecom_intrinsic_ichar_ (tree_type, arg1, &saved_expr1);
4273       expr_tree = ffecom_3 (COND_EXPR, tree_type,
4274                             saved_expr1,
4275                             expr_tree,
4276                             convert (tree_type, integer_zero_node));
4277       return expr_tree;
4278 #endif
4279
4280     case FFEINTRIN_impINDEX:
4281       break;
4282
4283     case FFEINTRIN_impLEN:
4284 #if 0
4285       break;                                    /* The simple approach. */
4286 #else
4287       return ffecom_intrinsic_len_ (arg1);      /* The more optimal approach. */
4288 #endif
4289
4290     case FFEINTRIN_impLGE:
4291     case FFEINTRIN_impLGT:
4292     case FFEINTRIN_impLLE:
4293     case FFEINTRIN_impLLT:
4294       break;
4295
4296     case FFEINTRIN_impLOG:
4297     case FFEINTRIN_impALOG:
4298     case FFEINTRIN_impCDLOG:
4299     case FFEINTRIN_impCLOG:
4300     case FFEINTRIN_impDLOG:
4301       if (bt == FFEINFO_basictypeCOMPLEX)
4302         {
4303           if (kt == FFEINFO_kindtypeREAL1)
4304             gfrt = FFECOM_gfrtCLOG;     /* Overlapping result okay. */
4305           else if (kt == FFEINFO_kindtypeREAL2)
4306             gfrt = FFECOM_gfrtCDLOG;    /* Overlapping result okay. */
4307         }
4308       break;
4309
4310     case FFEINTRIN_impLOG10:
4311     case FFEINTRIN_impALOG10:
4312     case FFEINTRIN_impDLOG10:
4313       if (gfrt != FFECOM_gfrt)
4314         break;  /* Already picked one, stick with it. */
4315
4316       if (kt == FFEINFO_kindtypeREAL1)
4317         /* We used to call FFECOM_gfrtALOG10 here.  */
4318         gfrt = FFECOM_gfrtL_LOG10;
4319       else if (kt == FFEINFO_kindtypeREAL2)
4320         /* We used to call FFECOM_gfrtDLOG10 here.  */
4321         gfrt = FFECOM_gfrtL_LOG10;
4322       break;
4323
4324     case FFEINTRIN_impMAX:
4325     case FFEINTRIN_impAMAX0:
4326     case FFEINTRIN_impAMAX1:
4327     case FFEINTRIN_impDMAX1:
4328     case FFEINTRIN_impMAX0:
4329     case FFEINTRIN_impMAX1:
4330       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4331         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4332       else
4333         arg1_type = tree_type;
4334       expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4335                             convert (arg1_type, ffecom_expr (arg1)),
4336                             convert (arg1_type, ffecom_expr (arg2)));
4337       for (; list != NULL; list = ffebld_trail (list))
4338         {
4339           if ((ffebld_head (list) == NULL)
4340               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4341             continue;
4342           expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4343                                 expr_tree,
4344                                 convert (arg1_type,
4345                                          ffecom_expr (ffebld_head (list))));
4346         }
4347       return convert (tree_type, expr_tree);
4348
4349     case FFEINTRIN_impMIN:
4350     case FFEINTRIN_impAMIN0:
4351     case FFEINTRIN_impAMIN1:
4352     case FFEINTRIN_impDMIN1:
4353     case FFEINTRIN_impMIN0:
4354     case FFEINTRIN_impMIN1:
4355       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4356         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4357       else
4358         arg1_type = tree_type;
4359       expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4360                             convert (arg1_type, ffecom_expr (arg1)),
4361                             convert (arg1_type, ffecom_expr (arg2)));
4362       for (; list != NULL; list = ffebld_trail (list))
4363         {
4364           if ((ffebld_head (list) == NULL)
4365               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4366             continue;
4367           expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4368                                 expr_tree,
4369                                 convert (arg1_type,
4370                                          ffecom_expr (ffebld_head (list))));
4371         }
4372       return convert (tree_type, expr_tree);
4373
4374     case FFEINTRIN_impMOD:
4375     case FFEINTRIN_impAMOD:
4376     case FFEINTRIN_impDMOD:
4377       if (bt != FFEINFO_basictypeREAL)
4378         return ffecom_2 (TRUNC_MOD_EXPR, tree_type,
4379                          convert (tree_type, ffecom_expr (arg1)),
4380                          convert (tree_type, ffecom_expr (arg2)));
4381
4382       if (kt == FFEINFO_kindtypeREAL1)
4383         /* We used to call FFECOM_gfrtAMOD here.  */
4384         gfrt = FFECOM_gfrtL_FMOD;
4385       else if (kt == FFEINFO_kindtypeREAL2)
4386         /* We used to call FFECOM_gfrtDMOD here.  */
4387         gfrt = FFECOM_gfrtL_FMOD;
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         if (arg3 != NULL)
5182           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5183         else
5184           arg3_tree = NULL_TREE;
5185
5186         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5187         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5188         arg2_len = build_tree_list (NULL_TREE, arg2_len);
5189         TREE_CHAIN (arg1_tree) = arg2_tree;
5190         TREE_CHAIN (arg2_tree) = arg2_len;
5191
5192         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5193                                   ffecom_gfrt_kindtype (gfrt),
5194                                   FALSE,
5195                                   NULL_TREE,
5196                                   arg1_tree,
5197                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5198                                   ffebld_nonter_hook (expr));
5199         if (arg3_tree != NULL_TREE)
5200           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5201                                      convert (TREE_TYPE (arg3_tree),
5202                                               expr_tree));
5203       }
5204       return expr_tree;
5205
5206     case FFEINTRIN_impFSTAT_subr:
5207       {
5208         tree arg1_tree;
5209         tree arg2_tree;
5210         tree arg3_tree;
5211
5212         arg1_tree = convert (ffecom_f2c_integer_type_node,
5213                              ffecom_expr (arg1));
5214         arg1_tree = ffecom_1 (ADDR_EXPR,
5215                               build_pointer_type (TREE_TYPE (arg1_tree)),
5216                               arg1_tree);
5217
5218         arg2_tree = convert (ffecom_f2c_ptr_to_integer_type_node,
5219                              ffecom_ptr_to_expr (arg2));
5220
5221         if (arg3 == NULL)
5222           arg3_tree = NULL_TREE;
5223         else
5224           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5225
5226         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5227         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5228         TREE_CHAIN (arg1_tree) = arg2_tree;
5229         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5230                                   ffecom_gfrt_kindtype (gfrt),
5231                                   FALSE,
5232                                   NULL_TREE,
5233                                   arg1_tree,
5234                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5235                                   ffebld_nonter_hook (expr));
5236         if (arg3_tree != NULL_TREE) {
5237           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5238                                      convert (TREE_TYPE (arg3_tree),
5239                                               expr_tree));
5240         }
5241       }
5242       return expr_tree;
5243
5244     case FFEINTRIN_impKILL_subr:
5245       {
5246         tree arg1_tree;
5247         tree arg2_tree;
5248         tree arg3_tree;
5249
5250         arg1_tree = convert (ffecom_f2c_integer_type_node,
5251                              ffecom_expr (arg1));
5252         arg1_tree = ffecom_1 (ADDR_EXPR,
5253                               build_pointer_type (TREE_TYPE (arg1_tree)),
5254                               arg1_tree);
5255
5256         arg2_tree = convert (ffecom_f2c_integer_type_node,
5257                              ffecom_expr (arg2));
5258         arg2_tree = ffecom_1 (ADDR_EXPR,
5259                               build_pointer_type (TREE_TYPE (arg2_tree)),
5260                               arg2_tree);
5261
5262         if (arg3 == NULL)
5263           arg3_tree = NULL_TREE;
5264         else
5265           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5266
5267         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5268         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5269         TREE_CHAIN (arg1_tree) = arg2_tree;
5270         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5271                                   ffecom_gfrt_kindtype (gfrt),
5272                                   FALSE,
5273                                   NULL_TREE,
5274                                   arg1_tree,
5275                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5276                                   ffebld_nonter_hook (expr));
5277         if (arg3_tree != NULL_TREE) {
5278           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5279                                      convert (TREE_TYPE (arg3_tree),
5280                                               expr_tree));
5281         }
5282       }
5283       return expr_tree;
5284
5285     case FFEINTRIN_impCTIME_subr:
5286     case FFEINTRIN_impTTYNAM_subr:
5287       {
5288         tree arg1_len = integer_zero_node;
5289         tree arg1_tree;
5290         tree arg2_tree;
5291
5292         arg1_tree = ffecom_arg_ptr_to_expr (arg2, &arg1_len);
5293
5294         arg2_tree = convert (((codegen_imp == FFEINTRIN_impCTIME_subr) ?
5295                               ffecom_f2c_longint_type_node :
5296                               ffecom_f2c_integer_type_node),
5297                              ffecom_expr (arg1));
5298         arg2_tree = ffecom_1 (ADDR_EXPR,
5299                               build_pointer_type (TREE_TYPE (arg2_tree)),
5300                               arg2_tree);
5301
5302         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5303         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5304         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5305         TREE_CHAIN (arg1_len) = arg2_tree;
5306         TREE_CHAIN (arg1_tree) = arg1_len;
5307
5308         expr_tree
5309           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5310                           ffecom_gfrt_kindtype (gfrt),
5311                           FALSE,
5312                           NULL_TREE,
5313                           arg1_tree,
5314                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5315                           ffebld_nonter_hook (expr));
5316         TREE_SIDE_EFFECTS (expr_tree) = 1;
5317       }
5318       return expr_tree;
5319
5320     case FFEINTRIN_impIRAND:
5321     case FFEINTRIN_impRAND:
5322       /* Arg defaults to 0 (normal random case) */
5323       {
5324         tree arg1_tree;
5325
5326         if (arg1 == NULL)
5327           arg1_tree = ffecom_integer_zero_node;
5328         else
5329           arg1_tree = ffecom_expr (arg1);
5330         arg1_tree = convert (ffecom_f2c_integer_type_node,
5331                              arg1_tree);
5332         arg1_tree = ffecom_1 (ADDR_EXPR,
5333                               build_pointer_type (TREE_TYPE (arg1_tree)),
5334                               arg1_tree);
5335         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5336
5337         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5338                                   ffecom_gfrt_kindtype (gfrt),
5339                                   FALSE,
5340                                   ((codegen_imp == FFEINTRIN_impIRAND) ?
5341                                    ffecom_f2c_integer_type_node :
5342                                    ffecom_f2c_real_type_node),
5343                                   arg1_tree,
5344                                   dest_tree, dest, dest_used,
5345                                   NULL_TREE, TRUE,
5346                                   ffebld_nonter_hook (expr));
5347       }
5348       return expr_tree;
5349
5350     case FFEINTRIN_impFTELL_subr:
5351     case FFEINTRIN_impUMASK_subr:
5352       {
5353         tree arg1_tree;
5354         tree arg2_tree;
5355
5356         arg1_tree = convert (ffecom_f2c_integer_type_node,
5357                              ffecom_expr (arg1));
5358         arg1_tree = ffecom_1 (ADDR_EXPR,
5359                               build_pointer_type (TREE_TYPE (arg1_tree)),
5360                               arg1_tree);
5361
5362         if (arg2 == NULL)
5363           arg2_tree = NULL_TREE;
5364         else
5365           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
5366
5367         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5368                                   ffecom_gfrt_kindtype (gfrt),
5369                                   FALSE,
5370                                   NULL_TREE,
5371                                   build_tree_list (NULL_TREE, arg1_tree),
5372                                   NULL_TREE, NULL, NULL, NULL_TREE,
5373                                   TRUE,
5374                                   ffebld_nonter_hook (expr));
5375         if (arg2_tree != NULL_TREE) {
5376           expr_tree = ffecom_modify (NULL_TREE, arg2_tree,
5377                                      convert (TREE_TYPE (arg2_tree),
5378                                               expr_tree));
5379         }
5380       }
5381       return expr_tree;
5382
5383     case FFEINTRIN_impCPU_TIME:
5384     case FFEINTRIN_impSECOND_subr:
5385       {
5386         tree arg1_tree;
5387
5388         arg1_tree = ffecom_expr_w (NULL_TREE, arg1);
5389
5390         expr_tree
5391           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5392                           ffecom_gfrt_kindtype (gfrt),
5393                           FALSE,
5394                           NULL_TREE,
5395                           NULL_TREE,
5396                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5397                           ffebld_nonter_hook (expr));
5398
5399         expr_tree
5400           = ffecom_modify (NULL_TREE, arg1_tree,
5401                            convert (TREE_TYPE (arg1_tree),
5402                                     expr_tree));
5403       }
5404       return expr_tree;
5405
5406     case FFEINTRIN_impDTIME_subr:
5407     case FFEINTRIN_impETIME_subr:
5408       {
5409         tree arg1_tree;
5410         tree result_tree;
5411
5412         result_tree = ffecom_expr_w (NULL_TREE, arg2);
5413
5414         arg1_tree = ffecom_ptr_to_expr (arg1);
5415
5416         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5417                                   ffecom_gfrt_kindtype (gfrt),
5418                                   FALSE,
5419                                   NULL_TREE,
5420                                   build_tree_list (NULL_TREE, arg1_tree),
5421                                   NULL_TREE, NULL, NULL, NULL_TREE,
5422                                   TRUE,
5423                                   ffebld_nonter_hook (expr));
5424         expr_tree = ffecom_modify (NULL_TREE, result_tree,
5425                                    convert (TREE_TYPE (result_tree),
5426                                             expr_tree));
5427       }
5428       return expr_tree;
5429
5430       /* Straightforward calls of libf2c routines: */
5431     case FFEINTRIN_impABORT:
5432     case FFEINTRIN_impACCESS:
5433     case FFEINTRIN_impBESJ0:
5434     case FFEINTRIN_impBESJ1:
5435     case FFEINTRIN_impBESJN:
5436     case FFEINTRIN_impBESY0:
5437     case FFEINTRIN_impBESY1:
5438     case FFEINTRIN_impBESYN:
5439     case FFEINTRIN_impCHDIR_func:
5440     case FFEINTRIN_impCHMOD_func:
5441     case FFEINTRIN_impDATE:
5442     case FFEINTRIN_impDATE_AND_TIME:
5443     case FFEINTRIN_impDBESJ0:
5444     case FFEINTRIN_impDBESJ1:
5445     case FFEINTRIN_impDBESJN:
5446     case FFEINTRIN_impDBESY0:
5447     case FFEINTRIN_impDBESY1:
5448     case FFEINTRIN_impDBESYN:
5449     case FFEINTRIN_impDTIME_func:
5450     case FFEINTRIN_impETIME_func:
5451     case FFEINTRIN_impFGETC_func:
5452     case FFEINTRIN_impFGET_func:
5453     case FFEINTRIN_impFNUM:
5454     case FFEINTRIN_impFPUTC_func:
5455     case FFEINTRIN_impFPUT_func:
5456     case FFEINTRIN_impFSEEK:
5457     case FFEINTRIN_impFSTAT_func:
5458     case FFEINTRIN_impFTELL_func:
5459     case FFEINTRIN_impGERROR:
5460     case FFEINTRIN_impGETARG:
5461     case FFEINTRIN_impGETCWD_func:
5462     case FFEINTRIN_impGETENV:
5463     case FFEINTRIN_impGETGID:
5464     case FFEINTRIN_impGETLOG:
5465     case FFEINTRIN_impGETPID:
5466     case FFEINTRIN_impGETUID:
5467     case FFEINTRIN_impGMTIME:
5468     case FFEINTRIN_impHOSTNM_func:
5469     case FFEINTRIN_impIDATE_unix:
5470     case FFEINTRIN_impIDATE_vxt:
5471     case FFEINTRIN_impIERRNO:
5472     case FFEINTRIN_impISATTY:
5473     case FFEINTRIN_impITIME:
5474     case FFEINTRIN_impKILL_func:
5475     case FFEINTRIN_impLINK_func:
5476     case FFEINTRIN_impLNBLNK:
5477     case FFEINTRIN_impLSTAT_func:
5478     case FFEINTRIN_impLTIME:
5479     case FFEINTRIN_impMCLOCK8:
5480     case FFEINTRIN_impMCLOCK:
5481     case FFEINTRIN_impPERROR:
5482     case FFEINTRIN_impRENAME_func:
5483     case FFEINTRIN_impSECNDS:
5484     case FFEINTRIN_impSECOND_func:
5485     case FFEINTRIN_impSLEEP:
5486     case FFEINTRIN_impSRAND:
5487     case FFEINTRIN_impSTAT_func:
5488     case FFEINTRIN_impSYMLNK_func:
5489     case FFEINTRIN_impSYSTEM_CLOCK:
5490     case FFEINTRIN_impSYSTEM_func:
5491     case FFEINTRIN_impTIME8:
5492     case FFEINTRIN_impTIME_unix:
5493     case FFEINTRIN_impTIME_vxt:
5494     case FFEINTRIN_impUMASK_func:
5495     case FFEINTRIN_impUNLINK_func:
5496       break;
5497
5498     case FFEINTRIN_impCTIME_func:       /* CHARACTER functions not handled here. */
5499     case FFEINTRIN_impFDATE_func:       /* CHARACTER functions not handled here. */
5500     case FFEINTRIN_impTTYNAM_func:      /* CHARACTER functions not handled here. */
5501     case FFEINTRIN_impNONE:
5502     case FFEINTRIN_imp:         /* Hush up gcc warning. */
5503       fprintf (stderr, "No %s implementation.\n",
5504                ffeintrin_name_implementation (ffebld_symter_implementation (ffebld_left (expr))));
5505       assert ("unimplemented intrinsic" == NULL);
5506       return error_mark_node;
5507     }
5508
5509   assert (gfrt != FFECOM_gfrt); /* Must have an implementation! */
5510
5511   expr_tree = ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt),
5512                                     ffebld_right (expr));
5513
5514   return ffecom_call_ (ffecom_gfrt_tree_ (gfrt), ffecom_gfrt_kindtype (gfrt),
5515                        (ffe_is_f2c_library () && ffecom_gfrt_complex_[gfrt]),
5516                        tree_type,
5517                        expr_tree, dest_tree, dest, dest_used,
5518                        NULL_TREE, TRUE,
5519                        ffebld_nonter_hook (expr));
5520
5521   /* See bottom of this file for f2c transforms used to determine
5522      many of the above implementations.  The info seems to confuse
5523      Emacs's C mode indentation, which is why it's been moved to
5524      the bottom of this source file.  */
5525 }
5526
5527 #endif
5528 /* For power (exponentiation) where right-hand operand is type INTEGER,
5529    generate in-line code to do it the fast way (which, if the operand
5530    is a constant, might just mean a series of multiplies).  */
5531
5532 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5533 static tree
5534 ffecom_expr_power_integer_ (ffebld expr)
5535 {
5536   tree l = ffecom_expr (ffebld_left (expr));
5537   tree r = ffecom_expr (ffebld_right (expr));
5538   tree ltype = TREE_TYPE (l);
5539   tree rtype = TREE_TYPE (r);
5540   tree result = NULL_TREE;
5541
5542   if (l == error_mark_node
5543       || r == error_mark_node)
5544     return error_mark_node;
5545
5546   if (TREE_CODE (r) == INTEGER_CST)
5547     {
5548       int sgn = tree_int_cst_sgn (r);
5549
5550       if (sgn == 0)
5551         return convert (ltype, integer_one_node);
5552
5553       if ((TREE_CODE (ltype) == INTEGER_TYPE)
5554           && (sgn < 0))
5555         {
5556           /* Reciprocal of integer is either 0, -1, or 1, so after
5557              calculating that (which we leave to the back end to do
5558              or not do optimally), don't bother with any multiplying.  */
5559
5560           result = ffecom_tree_divide_ (ltype,
5561                                         convert (ltype, integer_one_node),
5562                                         l,
5563                                         NULL_TREE, NULL, NULL, NULL_TREE);
5564           r = ffecom_1 (NEGATE_EXPR,
5565                         rtype,
5566                         r);
5567           if ((TREE_INT_CST_LOW (r) & 1) == 0)
5568             result = ffecom_1 (ABS_EXPR, rtype,
5569                                result);
5570         }
5571
5572       /* Generate appropriate series of multiplies, preceded
5573          by divide if the exponent is negative.  */
5574
5575       l = save_expr (l);
5576
5577       if (sgn < 0)
5578         {
5579           l = ffecom_tree_divide_ (ltype,
5580                                    convert (ltype, integer_one_node),
5581                                    l,
5582                                    NULL_TREE, NULL, NULL,
5583                                    ffebld_nonter_hook (expr));
5584           r = ffecom_1 (NEGATE_EXPR, rtype, r);
5585           assert (TREE_CODE (r) == INTEGER_CST);
5586
5587           if (tree_int_cst_sgn (r) < 0)
5588             {                   /* The "most negative" number.  */
5589               r = ffecom_1 (NEGATE_EXPR, rtype,
5590                             ffecom_2 (RSHIFT_EXPR, rtype,
5591                                       r,
5592                                       integer_one_node));
5593               l = save_expr (l);
5594               l = ffecom_2 (MULT_EXPR, ltype,
5595                             l,
5596                             l);
5597             }
5598         }
5599
5600       for (;;)
5601         {
5602           if (TREE_INT_CST_LOW (r) & 1)
5603             {
5604               if (result == NULL_TREE)
5605                 result = l;
5606               else
5607                 result = ffecom_2 (MULT_EXPR, ltype,
5608                                    result,
5609                                    l);
5610             }
5611
5612           r = ffecom_2 (RSHIFT_EXPR, rtype,
5613                         r,
5614                         integer_one_node);
5615           if (integer_zerop (r))
5616             break;
5617           assert (TREE_CODE (r) == INTEGER_CST);
5618
5619           l = save_expr (l);
5620           l = ffecom_2 (MULT_EXPR, ltype,
5621                         l,
5622                         l);
5623         }
5624       return result;
5625     }
5626
5627   /* Though rhs isn't a constant, in-line code cannot be expanded
5628      while transforming dummies
5629      because the back end cannot be easily convinced to generate
5630      stores (MODIFY_EXPR), handle temporaries, and so on before
5631      all the appropriate rtx's have been generated for things like
5632      dummy args referenced in rhs -- which doesn't happen until
5633      store_parm_decls() is called (expand_function_start, I believe,
5634      does the actual rtx-stuffing of PARM_DECLs).
5635
5636      So, in this case, let the caller generate the call to the
5637      run-time-library function to evaluate the power for us.  */
5638
5639   if (ffecom_transform_only_dummies_)
5640     return NULL_TREE;
5641
5642   /* Right-hand operand not a constant, expand in-line code to figure
5643      out how to do the multiplies, &c.
5644
5645      The returned expression is expressed this way in GNU C, where l and
5646      r are the "inputs":
5647
5648      ({ typeof (r) rtmp = r;
5649         typeof (l) ltmp = l;
5650         typeof (l) result;
5651
5652         if (rtmp == 0)
5653           result = 1;
5654         else
5655           {
5656             if ((basetypeof (l) == basetypeof (int))
5657                 && (rtmp < 0))
5658               {
5659                 result = ((typeof (l)) 1) / ltmp;
5660                 if ((ltmp < 0) && (((-rtmp) & 1) == 0))
5661                   result = -result;
5662               }
5663             else
5664               {
5665                 result = 1;
5666                 if ((basetypeof (l) != basetypeof (int))
5667                     && (rtmp < 0))
5668                   {
5669                     ltmp = ((typeof (l)) 1) / ltmp;
5670                     rtmp = -rtmp;
5671                     if (rtmp < 0)
5672                       {
5673                         rtmp = -(rtmp >> 1);
5674                         ltmp *= ltmp;
5675                       }
5676                   }
5677                 for (;;)
5678                   {
5679                     if (rtmp & 1)
5680                       result *= ltmp;
5681                     if ((rtmp >>= 1) == 0)
5682                       break;
5683                     ltmp *= ltmp;
5684                   }
5685               }
5686           }
5687         result;
5688      })
5689
5690      Note that some of the above is compile-time collapsable, such as
5691      the first part of the if statements that checks the base type of
5692      l against int.  The if statements are phrased that way to suggest
5693      an easy way to generate the if/else constructs here, knowing that
5694      the back end should (and probably does) eliminate the resulting
5695      dead code (either the int case or the non-int case), something
5696      it couldn't do without the redundant phrasing, requiring explicit
5697      dead-code elimination here, which would be kind of difficult to
5698      read.  */
5699
5700   {
5701     tree rtmp;
5702     tree ltmp;
5703     tree divide;
5704     tree basetypeof_l_is_int;
5705     tree se;
5706     tree t;
5707
5708     basetypeof_l_is_int
5709       = build_int_2 ((TREE_CODE (ltype) == INTEGER_TYPE), 0);
5710
5711     se = expand_start_stmt_expr ();
5712
5713     ffecom_start_compstmt ();
5714
5715 #ifndef HAHA
5716     rtmp = ffecom_make_tempvar ("power_r", rtype,
5717                                 FFETARGET_charactersizeNONE, -1);
5718     ltmp = ffecom_make_tempvar ("power_l", ltype,
5719                                 FFETARGET_charactersizeNONE, -1);
5720     result = ffecom_make_tempvar ("power_res", ltype,
5721                                   FFETARGET_charactersizeNONE, -1);
5722     if (TREE_CODE (ltype) == COMPLEX_TYPE
5723         || TREE_CODE (ltype) == RECORD_TYPE)
5724       divide = ffecom_make_tempvar ("power_div", ltype,
5725                                     FFETARGET_charactersizeNONE, -1);
5726     else
5727       divide = NULL_TREE;
5728 #else  /* HAHA */
5729     {
5730       tree hook;
5731
5732       hook = ffebld_nonter_hook (expr);
5733       assert (hook);
5734       assert (TREE_CODE (hook) == TREE_VEC);
5735       assert (TREE_VEC_LENGTH (hook) == 4);
5736       rtmp = TREE_VEC_ELT (hook, 0);
5737       ltmp = TREE_VEC_ELT (hook, 1);
5738       result = TREE_VEC_ELT (hook, 2);
5739       divide = TREE_VEC_ELT (hook, 3);
5740       if (TREE_CODE (ltype) == COMPLEX_TYPE
5741           || TREE_CODE (ltype) == RECORD_TYPE)
5742         assert (divide);
5743       else
5744         assert (! divide);
5745     }
5746 #endif  /* HAHA */
5747
5748     expand_expr_stmt (ffecom_modify (void_type_node,
5749                                      rtmp,
5750                                      r));
5751     expand_expr_stmt (ffecom_modify (void_type_node,
5752                                      ltmp,
5753                                      l));
5754     expand_start_cond (ffecom_truth_value
5755                        (ffecom_2 (EQ_EXPR, integer_type_node,
5756                                   rtmp,
5757                                   convert (rtype, integer_zero_node))),
5758                        0);
5759     expand_expr_stmt (ffecom_modify (void_type_node,
5760                                      result,
5761                                      convert (ltype, integer_one_node)));
5762     expand_start_else ();
5763     if (! integer_zerop (basetypeof_l_is_int))
5764       {
5765         expand_start_cond (ffecom_2 (LT_EXPR, integer_type_node,
5766                                      rtmp,
5767                                      convert (rtype,
5768                                               integer_zero_node)),
5769                            0);
5770         expand_expr_stmt (ffecom_modify (void_type_node,
5771                                          result,
5772                                          ffecom_tree_divide_
5773                                          (ltype,
5774                                           convert (ltype, integer_one_node),
5775                                           ltmp,
5776                                           NULL_TREE, NULL, NULL,
5777                                           divide)));
5778         expand_start_cond (ffecom_truth_value
5779                            (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5780                                       ffecom_2 (LT_EXPR, integer_type_node,
5781                                                 ltmp,
5782                                                 convert (ltype,
5783                                                          integer_zero_node)),
5784                                       ffecom_2 (EQ_EXPR, integer_type_node,
5785                                                 ffecom_2 (BIT_AND_EXPR,
5786                                                           rtype,
5787                                                           ffecom_1 (NEGATE_EXPR,
5788                                                                     rtype,
5789                                                                     rtmp),
5790                                                           convert (rtype,
5791                                                                    integer_one_node)),
5792                                                 convert (rtype,
5793                                                          integer_zero_node)))),
5794                            0);
5795         expand_expr_stmt (ffecom_modify (void_type_node,
5796                                          result,
5797                                          ffecom_1 (NEGATE_EXPR,
5798                                                    ltype,
5799                                                    result)));
5800         expand_end_cond ();
5801         expand_start_else ();
5802       }
5803     expand_expr_stmt (ffecom_modify (void_type_node,
5804                                      result,
5805                                      convert (ltype, integer_one_node)));
5806     expand_start_cond (ffecom_truth_value
5807                        (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5808                                   ffecom_truth_value_invert
5809                                   (basetypeof_l_is_int),
5810                                   ffecom_2 (LT_EXPR, integer_type_node,
5811                                             rtmp,
5812                                             convert (rtype,
5813                                                      integer_zero_node)))),
5814                        0);
5815     expand_expr_stmt (ffecom_modify (void_type_node,
5816                                      ltmp,
5817                                      ffecom_tree_divide_
5818                                      (ltype,
5819                                       convert (ltype, integer_one_node),
5820                                       ltmp,
5821                                       NULL_TREE, NULL, NULL,
5822                                       divide)));
5823     expand_expr_stmt (ffecom_modify (void_type_node,
5824                                      rtmp,
5825                                      ffecom_1 (NEGATE_EXPR, rtype,
5826                                                rtmp)));
5827     expand_start_cond (ffecom_truth_value
5828                        (ffecom_2 (LT_EXPR, integer_type_node,
5829                                   rtmp,
5830                                   convert (rtype, integer_zero_node))),
5831                        0);
5832     expand_expr_stmt (ffecom_modify (void_type_node,
5833                                      rtmp,
5834                                      ffecom_1 (NEGATE_EXPR, rtype,
5835                                                ffecom_2 (RSHIFT_EXPR,
5836                                                          rtype,
5837                                                          rtmp,
5838                                                          integer_one_node))));
5839     expand_expr_stmt (ffecom_modify (void_type_node,
5840                                      ltmp,
5841                                      ffecom_2 (MULT_EXPR, ltype,
5842                                                ltmp,
5843                                                ltmp)));
5844     expand_end_cond ();
5845     expand_end_cond ();
5846     expand_start_loop (1);
5847     expand_start_cond (ffecom_truth_value
5848                        (ffecom_2 (BIT_AND_EXPR, rtype,
5849                                   rtmp,
5850                                   convert (rtype, integer_one_node))),
5851                        0);
5852     expand_expr_stmt (ffecom_modify (void_type_node,
5853                                      result,
5854                                      ffecom_2 (MULT_EXPR, ltype,
5855                                                result,
5856                                                ltmp)));
5857     expand_end_cond ();
5858     expand_exit_loop_if_false (NULL,
5859                                ffecom_truth_value
5860                                (ffecom_modify (rtype,
5861                                                rtmp,
5862                                                ffecom_2 (RSHIFT_EXPR,
5863                                                          rtype,
5864                                                          rtmp,
5865                                                          integer_one_node))));
5866     expand_expr_stmt (ffecom_modify (void_type_node,
5867                                      ltmp,
5868                                      ffecom_2 (MULT_EXPR, ltype,
5869                                                ltmp,
5870                                                ltmp)));
5871     expand_end_loop ();
5872     expand_end_cond ();
5873     if (!integer_zerop (basetypeof_l_is_int))
5874       expand_end_cond ();
5875     expand_expr_stmt (result);
5876
5877     t = ffecom_end_compstmt ();
5878
5879     result = expand_end_stmt_expr (se);
5880
5881     /* This code comes from c-parse.in, after its expand_end_stmt_expr.  */
5882
5883     if (TREE_CODE (t) == BLOCK)
5884       {
5885         /* Make a BIND_EXPR for the BLOCK already made.  */
5886         result = build (BIND_EXPR, TREE_TYPE (result),
5887                         NULL_TREE, result, t);
5888         /* Remove the block from the tree at this point.
5889            It gets put back at the proper place
5890            when the BIND_EXPR is expanded.  */
5891         delete_block (t);
5892       }
5893     else
5894       result = t;
5895   }
5896
5897   return result;
5898 }
5899
5900 #endif
5901 /* ffecom_expr_transform_ -- Transform symbols in expr
5902
5903    ffebld expr;  // FFE expression.
5904    ffecom_expr_transform_ (expr);
5905
5906    Recursive descent on expr while transforming any untransformed SYMTERs.  */
5907
5908 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5909 static void
5910 ffecom_expr_transform_ (ffebld expr)
5911 {
5912   tree t;
5913   ffesymbol s;
5914
5915 tail_recurse:                   /* :::::::::::::::::::: */
5916
5917   if (expr == NULL)
5918     return;
5919
5920   switch (ffebld_op (expr))
5921     {
5922     case FFEBLD_opSYMTER:
5923       s = ffebld_symter (expr);
5924       t = ffesymbol_hook (s).decl_tree;
5925       if ((t == NULL_TREE)
5926           && ((ffesymbol_kind (s) != FFEINFO_kindNONE)
5927               || ((ffesymbol_where (s) != FFEINFO_whereNONE)
5928                   && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC))))
5929         {
5930           s = ffecom_sym_transform_ (s);
5931           t = ffesymbol_hook (s).decl_tree;     /* Sfunc expr non-dummy,
5932                                                    DIMENSION expr? */
5933         }
5934       break;                    /* Ok if (t == NULL) here. */
5935
5936     case FFEBLD_opITEM:
5937       ffecom_expr_transform_ (ffebld_head (expr));
5938       expr = ffebld_trail (expr);
5939       goto tail_recurse;        /* :::::::::::::::::::: */
5940
5941     default:
5942       break;
5943     }
5944
5945   switch (ffebld_arity (expr))
5946     {
5947     case 2:
5948       ffecom_expr_transform_ (ffebld_left (expr));
5949       expr = ffebld_right (expr);
5950       goto tail_recurse;        /* :::::::::::::::::::: */
5951
5952     case 1:
5953       expr = ffebld_left (expr);
5954       goto tail_recurse;        /* :::::::::::::::::::: */
5955
5956     default:
5957       break;
5958     }
5959
5960   return;
5961 }
5962
5963 #endif
5964 /* Make a type based on info in live f2c.h file.  */
5965
5966 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5967 static void
5968 ffecom_f2c_make_type_ (tree *type, int tcode, const char *name)
5969 {
5970   switch (tcode)
5971     {
5972     case FFECOM_f2ccodeCHAR:
5973       *type = make_signed_type (CHAR_TYPE_SIZE);
5974       break;
5975
5976     case FFECOM_f2ccodeSHORT:
5977       *type = make_signed_type (SHORT_TYPE_SIZE);
5978       break;
5979
5980     case FFECOM_f2ccodeINT:
5981       *type = make_signed_type (INT_TYPE_SIZE);
5982       break;
5983
5984     case FFECOM_f2ccodeLONG:
5985       *type = make_signed_type (LONG_TYPE_SIZE);
5986       break;
5987
5988     case FFECOM_f2ccodeLONGLONG:
5989       *type = make_signed_type (LONG_LONG_TYPE_SIZE);
5990       break;
5991
5992     case FFECOM_f2ccodeCHARPTR:
5993       *type = build_pointer_type (DEFAULT_SIGNED_CHAR
5994                                   ? signed_char_type_node
5995                                   : unsigned_char_type_node);
5996       break;
5997
5998     case FFECOM_f2ccodeFLOAT:
5999       *type = make_node (REAL_TYPE);
6000       TYPE_PRECISION (*type) = FLOAT_TYPE_SIZE;
6001       layout_type (*type);
6002       break;
6003
6004     case FFECOM_f2ccodeDOUBLE:
6005       *type = make_node (REAL_TYPE);
6006       TYPE_PRECISION (*type) = DOUBLE_TYPE_SIZE;
6007       layout_type (*type);
6008       break;
6009
6010     case FFECOM_f2ccodeLONGDOUBLE:
6011       *type = make_node (REAL_TYPE);
6012       TYPE_PRECISION (*type) = LONG_DOUBLE_TYPE_SIZE;
6013       layout_type (*type);
6014       break;
6015
6016     case FFECOM_f2ccodeTWOREALS:
6017       *type = ffecom_make_complex_type_ (ffecom_f2c_real_type_node);
6018       break;
6019
6020     case FFECOM_f2ccodeTWODOUBLEREALS:
6021       *type = ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node);
6022       break;
6023
6024     default:
6025       assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL);
6026       *type = error_mark_node;
6027       return;
6028     }
6029
6030   pushdecl (build_decl (TYPE_DECL,
6031                         ffecom_get_invented_identifier ("__g77_f2c_%s", name),
6032                         *type));
6033 }
6034
6035 #endif
6036 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6037 /* Set the f2c list-directed-I/O code for whatever (integral) type has the
6038    given size.  */
6039
6040 static void
6041 ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
6042                           int code)
6043 {
6044   int j;
6045   tree t;
6046
6047   for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
6048     if ((t = ffecom_tree_type[bt][j]) != NULL_TREE
6049         && compare_tree_int (TYPE_SIZE (t), size) == 0)
6050       {
6051         assert (code != -1);
6052         ffecom_f2c_typecode_[bt][j] = code;
6053         code = -1;
6054       }
6055 }
6056
6057 #endif
6058 /* Finish up globals after doing all program units in file
6059
6060    Need to handle only uninitialized COMMON areas.  */
6061
6062 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6063 static ffeglobal
6064 ffecom_finish_global_ (ffeglobal global)
6065 {
6066   tree cbtype;
6067   tree cbt;
6068   tree size;
6069
6070   if (ffeglobal_type (global) != FFEGLOBAL_typeCOMMON)
6071       return global;
6072
6073   if (ffeglobal_common_init (global))
6074       return global;
6075
6076   cbt = ffeglobal_hook (global);
6077   if ((cbt == NULL_TREE)
6078       || !ffeglobal_common_have_size (global))
6079     return global;              /* No need to make common, never ref'd. */
6080
6081   DECL_EXTERNAL (cbt) = 0;
6082
6083   /* Give the array a size now.  */
6084
6085   size = build_int_2 ((ffeglobal_common_size (global)
6086                       + ffeglobal_common_pad (global)) - 1,
6087                       0);
6088
6089   cbtype = TREE_TYPE (cbt);
6090   TYPE_DOMAIN (cbtype) = build_range_type (integer_type_node,
6091                                            integer_zero_node,
6092                                            size);
6093   if (!TREE_TYPE (size))
6094     TREE_TYPE (size) = TYPE_DOMAIN (cbtype);
6095   layout_type (cbtype);
6096
6097   cbt = start_decl (cbt, FALSE);
6098   assert (cbt == ffeglobal_hook (global));
6099
6100   finish_decl (cbt, NULL_TREE, FALSE);
6101
6102   return global;
6103 }
6104
6105 #endif
6106 /* Finish up any untransformed symbols.  */
6107
6108 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6109 static ffesymbol
6110 ffecom_finish_symbol_transform_ (ffesymbol s)
6111 {
6112   if ((s == NULL) || (TREE_CODE (current_function_decl) == ERROR_MARK))
6113     return s;
6114
6115   /* It's easy to know to transform an untransformed symbol, to make sure
6116      we put out debugging info for it.  But COMMON variables, unlike
6117      EQUIVALENCE ones, aren't given declarations in addition to the
6118      tree expressions that specify offsets, because COMMON variables
6119      can be referenced in the outer scope where only dummy arguments
6120      (PARM_DECLs) should really be seen.  To be safe, just don't do any
6121      VAR_DECLs for COMMON variables when we transform them for real
6122      use, and therefore we do all the VAR_DECL creating here.  */
6123
6124   if (ffesymbol_hook (s).decl_tree == NULL_TREE)
6125     {
6126       if (ffesymbol_kind (s) != FFEINFO_kindNONE
6127           || (ffesymbol_where (s) != FFEINFO_whereNONE
6128               && ffesymbol_where (s) != FFEINFO_whereINTRINSIC
6129               && ffesymbol_where (s) != FFEINFO_whereDUMMY))
6130         /* Not transformed, and not CHARACTER*(*), and not a dummy
6131            argument, which can happen only if the entry point names
6132            it "rides in on" are all invalidated for other reasons.  */
6133         s = ffecom_sym_transform_ (s);
6134     }
6135
6136   if ((ffesymbol_where (s) == FFEINFO_whereCOMMON)
6137       && (ffesymbol_hook (s).decl_tree != error_mark_node))
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
6149   return s;
6150 }
6151
6152 #endif
6153 /* Append underscore(s) to name before calling get_identifier.  "us"
6154    is nonzero if the name already contains an underscore and thus
6155    needs two underscores appended.  */
6156
6157 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6158 static tree
6159 ffecom_get_appended_identifier_ (char us, const char *name)
6160 {
6161   int i;
6162   char *newname;
6163   tree id;
6164
6165   newname = xmalloc ((i = strlen (name)) + 1
6166                      + ffe_is_underscoring ()
6167                      + us);
6168   memcpy (newname, name, i);
6169   newname[i] = '_';
6170   newname[i + us] = '_';
6171   newname[i + 1 + us] = '\0';
6172   id = get_identifier (newname);
6173
6174   free (newname);
6175
6176   return id;
6177 }
6178
6179 #endif
6180 /* Decide whether to append underscore to name before calling
6181    get_identifier.  */
6182
6183 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6184 static tree
6185 ffecom_get_external_identifier_ (ffesymbol s)
6186 {
6187   char us;
6188   const char *name = ffesymbol_text (s);
6189
6190   /* If name is a built-in name, just return it as is.  */
6191
6192   if (!ffe_is_underscoring ()
6193       || (strcmp (name, FFETARGET_nameBLANK_COMMON) == 0)
6194 #if FFETARGET_isENFORCED_MAIN_NAME
6195       || (strcmp (name, FFETARGET_nameENFORCED_NAME) == 0)
6196 #else
6197       || (strcmp (name, FFETARGET_nameUNNAMED_MAIN) == 0)
6198 #endif
6199       || (strcmp (name, FFETARGET_nameUNNAMED_BLOCK_DATA) == 0))
6200     return get_identifier (name);
6201
6202   us = ffe_is_second_underscore ()
6203     ? (strchr (name, '_') != NULL)
6204       : 0;
6205
6206   return ffecom_get_appended_identifier_ (us, name);
6207 }
6208
6209 #endif
6210 /* Decide whether to append underscore to internal name before calling
6211    get_identifier.
6212
6213    This is for non-external, top-function-context names only.  Transform
6214    identifier so it doesn't conflict with the transformed result
6215    of using a _different_ external name.  E.g. if "CALL FOO" is
6216    transformed into "FOO_();", then the variable in "FOO_ = 3"
6217    must be transformed into something that does not conflict, since
6218    these two things should be independent.
6219
6220    The transformation is as follows.  If the name does not contain
6221    an underscore, there is no possible conflict, so just return.
6222    If the name does contain an underscore, then transform it just
6223    like we transform an external identifier.  */
6224
6225 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6226 static tree
6227 ffecom_get_identifier_ (const char *name)
6228 {
6229   /* If name does not contain an underscore, just return it as is.  */
6230
6231   if (!ffe_is_underscoring ()
6232       || (strchr (name, '_') == NULL))
6233     return get_identifier (name);
6234
6235   return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
6236                                           name);
6237 }
6238
6239 #endif
6240 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
6241
6242    tree t;
6243    ffesymbol s;  // kindFUNCTION, whereIMMEDIATE.
6244    t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
6245          ffesymbol_kindtype(s));
6246
6247    Call after setting up containing function and getting trees for all
6248    other symbols.  */
6249
6250 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6251 static tree
6252 ffecom_gen_sfuncdef_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt)
6253 {
6254   ffebld expr = ffesymbol_sfexpr (s);
6255   tree type;
6256   tree func;
6257   tree result;
6258   bool charfunc = (bt == FFEINFO_basictypeCHARACTER);
6259   static bool recurse = FALSE;
6260   int old_lineno = lineno;
6261   const char *old_input_filename = input_filename;
6262
6263   ffecom_nested_entry_ = s;
6264
6265   /* For now, we don't have a handy pointer to where the sfunc is actually
6266      defined, though that should be easy to add to an ffesymbol. (The
6267      token/where info available might well point to the place where the type
6268      of the sfunc is declared, especially if that precedes the place where
6269      the sfunc itself is defined, which is typically the case.)  We should
6270      put out a null pointer rather than point somewhere wrong, but I want to
6271      see how it works at this point.  */
6272
6273   input_filename = ffesymbol_where_filename (s);
6274   lineno = ffesymbol_where_filelinenum (s);
6275
6276   /* Pretransform the expression so any newly discovered things belong to the
6277      outer program unit, not to the statement function. */
6278
6279   ffecom_expr_transform_ (expr);
6280
6281   /* Make sure no recursive invocation of this fn (a specific case of failing
6282      to pretransform an sfunc's expression, i.e. where its expression
6283      references another untransformed sfunc) happens. */
6284
6285   assert (!recurse);
6286   recurse = TRUE;
6287
6288   push_f_function_context ();
6289
6290   if (charfunc)
6291     type = void_type_node;
6292   else
6293     {
6294       type = ffecom_tree_type[bt][kt];
6295       if (type == NULL_TREE)
6296         type = integer_type_node;       /* _sym_exec_transition reports
6297                                            error. */
6298     }
6299
6300   start_function (ffecom_get_identifier_ (ffesymbol_text (s)),
6301                   build_function_type (type, NULL_TREE),
6302                   1,            /* nested/inline */
6303                   0);           /* TREE_PUBLIC */
6304
6305   /* We don't worry about COMPLEX return values here, because this is
6306      entirely internal to our code, and gcc has the ability to return COMPLEX
6307      directly as a value.  */
6308
6309   if (charfunc)
6310     {                           /* Prepend arg for where result goes. */
6311       tree type;
6312
6313       type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
6314
6315       result = ffecom_get_invented_identifier ("__g77_%s", "result");
6316
6317       ffecom_char_enhance_arg_ (&type, s);      /* Ignore returned length. */
6318
6319       type = build_pointer_type (type);
6320       result = build_decl (PARM_DECL, result, type);
6321
6322       push_parm_decl (result);
6323     }
6324   else
6325     result = NULL_TREE;         /* Not ref'd if !charfunc. */
6326
6327   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s), TRUE);
6328
6329   store_parm_decls (0);
6330
6331   ffecom_start_compstmt ();
6332
6333   if (expr != NULL)
6334     {
6335       if (charfunc)
6336         {
6337           ffetargetCharacterSize sz = ffesymbol_size (s);
6338           tree result_length;
6339
6340           result_length = build_int_2 (sz, 0);
6341           TREE_TYPE (result_length) = ffecom_f2c_ftnlen_type_node;
6342
6343           ffecom_prepare_let_char_ (sz, expr);
6344
6345           ffecom_prepare_end ();
6346
6347           ffecom_let_char_ (result, result_length, sz, expr);
6348           expand_null_return ();
6349         }
6350       else
6351         {
6352           ffecom_prepare_expr (expr);
6353
6354           ffecom_prepare_end ();
6355
6356           expand_return (ffecom_modify (NULL_TREE,
6357                                         DECL_RESULT (current_function_decl),
6358                                         ffecom_expr (expr)));
6359         }
6360     }
6361
6362   ffecom_end_compstmt ();
6363
6364   func = current_function_decl;
6365   finish_function (1);
6366
6367   pop_f_function_context ();
6368
6369   recurse = FALSE;
6370
6371   lineno = old_lineno;
6372   input_filename = old_input_filename;
6373
6374   ffecom_nested_entry_ = NULL;
6375
6376   return func;
6377 }
6378
6379 #endif
6380
6381 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6382 static const char *
6383 ffecom_gfrt_args_ (ffecomGfrt ix)
6384 {
6385   return ffecom_gfrt_argstring_[ix];
6386 }
6387
6388 #endif
6389 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6390 static tree
6391 ffecom_gfrt_tree_ (ffecomGfrt ix)
6392 {
6393   if (ffecom_gfrt_[ix] == NULL_TREE)
6394     ffecom_make_gfrt_ (ix);
6395
6396   return ffecom_1 (ADDR_EXPR,
6397                    build_pointer_type (TREE_TYPE (ffecom_gfrt_[ix])),
6398                    ffecom_gfrt_[ix]);
6399 }
6400
6401 #endif
6402 /* Return initialize-to-zero expression for this VAR_DECL.  */
6403
6404 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6405 /* A somewhat evil way to prevent the garbage collector
6406    from collecting 'tree' structures.  */
6407 #define NUM_TRACKED_CHUNK 63
6408 static struct tree_ggc_tracker
6409 {
6410   struct tree_ggc_tracker *next;
6411   tree trees[NUM_TRACKED_CHUNK];
6412 } *tracker_head = NULL;
6413
6414 static void
6415 mark_tracker_head (void *arg)
6416 {
6417   struct tree_ggc_tracker *head;
6418   int i;
6419
6420   for (head = * (struct tree_ggc_tracker **) arg;
6421        head != NULL;
6422        head = head->next)
6423   {
6424     ggc_mark (head);
6425     for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6426       ggc_mark_tree (head->trees[i]);
6427   }
6428 }
6429
6430 void
6431 ffecom_save_tree_forever (tree t)
6432 {
6433   int i;
6434   if (tracker_head != NULL)
6435     for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6436       if (tracker_head->trees[i] == NULL)
6437         {
6438           tracker_head->trees[i] = t;
6439           return;
6440         }
6441
6442   {
6443     /* Need to allocate a new block.  */
6444     struct tree_ggc_tracker *old_head = tracker_head;
6445
6446     tracker_head = ggc_alloc (sizeof (*tracker_head));
6447     tracker_head->next = old_head;
6448     tracker_head->trees[0] = t;
6449     for (i = 1; i < NUM_TRACKED_CHUNK; i++)
6450       tracker_head->trees[i] = NULL;
6451   }
6452 }
6453
6454 static tree
6455 ffecom_init_zero_ (tree decl)
6456 {
6457   tree init;
6458   int incremental = TREE_STATIC (decl);
6459   tree type = TREE_TYPE (decl);
6460
6461   if (incremental)
6462     {
6463       make_decl_rtl (decl, NULL, TREE_PUBLIC (decl) ? 1 : 0);
6464       assemble_variable (decl, TREE_PUBLIC (decl) ? 1 : 0, 0, 1);
6465     }
6466
6467   if ((TREE_CODE (type) != ARRAY_TYPE)
6468       && (TREE_CODE (type) != RECORD_TYPE)
6469       && (TREE_CODE (type) != UNION_TYPE)
6470       && !incremental)
6471     init = convert (type, integer_zero_node);
6472   else if (!incremental)
6473     {
6474       init = build (CONSTRUCTOR, type, NULL_TREE, NULL_TREE);
6475       TREE_CONSTANT (init) = 1;
6476       TREE_STATIC (init) = 1;
6477     }
6478   else
6479     {
6480       assemble_zeros (int_size_in_bytes (type));
6481       init = error_mark_node;
6482     }
6483
6484   return init;
6485 }
6486
6487 #endif
6488 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6489 static tree
6490 ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
6491                          tree *maybe_tree)
6492 {
6493   tree expr_tree;
6494   tree length_tree;
6495
6496   switch (ffebld_op (arg))
6497     {
6498     case FFEBLD_opCONTER:       /* For F90, check 0-length. */
6499       if (ffetarget_length_character1
6500           (ffebld_constant_character1
6501            (ffebld_conter (arg))) == 0)
6502         {
6503           *maybe_tree = integer_zero_node;
6504           return convert (tree_type, integer_zero_node);
6505         }
6506
6507       *maybe_tree = integer_one_node;
6508       expr_tree = build_int_2 (*ffetarget_text_character1
6509                                (ffebld_constant_character1
6510                                 (ffebld_conter (arg))),
6511                                0);
6512       TREE_TYPE (expr_tree) = tree_type;
6513       return expr_tree;
6514
6515     case FFEBLD_opSYMTER:
6516     case FFEBLD_opARRAYREF:
6517     case FFEBLD_opFUNCREF:
6518     case FFEBLD_opSUBSTR:
6519       ffecom_char_args_ (&expr_tree, &length_tree, arg);
6520
6521       if ((expr_tree == error_mark_node)
6522           || (length_tree == error_mark_node))
6523         {
6524           *maybe_tree = error_mark_node;
6525           return error_mark_node;
6526         }
6527
6528       if (integer_zerop (length_tree))
6529         {
6530           *maybe_tree = integer_zero_node;
6531           return convert (tree_type, integer_zero_node);
6532         }
6533
6534       expr_tree
6535         = ffecom_1 (INDIRECT_REF,
6536                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6537                     expr_tree);
6538       expr_tree
6539         = ffecom_2 (ARRAY_REF,
6540                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6541                     expr_tree,
6542                     integer_one_node);
6543       expr_tree = convert (tree_type, expr_tree);
6544
6545       if (TREE_CODE (length_tree) == INTEGER_CST)
6546         *maybe_tree = integer_one_node;
6547       else                      /* Must check length at run time.  */
6548         *maybe_tree
6549           = ffecom_truth_value
6550             (ffecom_2 (GT_EXPR, integer_type_node,
6551                        length_tree,
6552                        ffecom_f2c_ftnlen_zero_node));
6553       return expr_tree;
6554
6555     case FFEBLD_opPAREN:
6556     case FFEBLD_opCONVERT:
6557       if (ffeinfo_size (ffebld_info (arg)) == 0)
6558         {
6559           *maybe_tree = integer_zero_node;
6560           return convert (tree_type, integer_zero_node);
6561         }
6562       return ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6563                                       maybe_tree);
6564
6565     case FFEBLD_opCONCATENATE:
6566       {
6567         tree maybe_left;
6568         tree maybe_right;
6569         tree expr_left;
6570         tree expr_right;
6571
6572         expr_left = ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6573                                              &maybe_left);
6574         expr_right = ffecom_intrinsic_ichar_ (tree_type, ffebld_right (arg),
6575                                               &maybe_right);
6576         *maybe_tree = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
6577                                 maybe_left,
6578                                 maybe_right);
6579         expr_tree = ffecom_3 (COND_EXPR, tree_type,
6580                               maybe_left,
6581                               expr_left,
6582                               expr_right);
6583         return expr_tree;
6584       }
6585
6586     default:
6587       assert ("bad op in ICHAR" == NULL);
6588       return error_mark_node;
6589     }
6590 }
6591
6592 #endif
6593 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
6594
6595    tree length_arg;
6596    ffebld expr;
6597    length_arg = ffecom_intrinsic_len_ (expr);
6598
6599    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
6600    subexpressions by constructing the appropriate tree for the
6601    length-of-character-text argument in a calling sequence.  */
6602
6603 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6604 static tree
6605 ffecom_intrinsic_len_ (ffebld expr)
6606 {
6607   ffetargetCharacter1 val;
6608   tree length;
6609
6610   switch (ffebld_op (expr))
6611     {
6612     case FFEBLD_opCONTER:
6613       val = ffebld_constant_character1 (ffebld_conter (expr));
6614       length = build_int_2 (ffetarget_length_character1 (val), 0);
6615       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6616       break;
6617
6618     case FFEBLD_opSYMTER:
6619       {
6620         ffesymbol s = ffebld_symter (expr);
6621         tree item;
6622
6623         item = ffesymbol_hook (s).decl_tree;
6624         if (item == NULL_TREE)
6625           {
6626             s = ffecom_sym_transform_ (s);
6627             item = ffesymbol_hook (s).decl_tree;
6628           }
6629         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
6630           {
6631             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
6632               length = ffesymbol_hook (s).length_tree;
6633             else
6634               {
6635                 length = build_int_2 (ffesymbol_size (s), 0);
6636                 TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6637               }
6638           }
6639         else if (item == error_mark_node)
6640           length = error_mark_node;
6641         else                    /* FFEINFO_kindFUNCTION: */
6642           length = NULL_TREE;
6643       }
6644       break;
6645
6646     case FFEBLD_opARRAYREF:
6647       length = ffecom_intrinsic_len_ (ffebld_left (expr));
6648       break;
6649
6650     case FFEBLD_opSUBSTR:
6651       {
6652         ffebld start;
6653         ffebld end;
6654         ffebld thing = ffebld_right (expr);
6655         tree start_tree;
6656         tree end_tree;
6657
6658         assert (ffebld_op (thing) == FFEBLD_opITEM);
6659         start = ffebld_head (thing);
6660         thing = ffebld_trail (thing);
6661         assert (ffebld_trail (thing) == NULL);
6662         end = ffebld_head (thing);
6663
6664         length = ffecom_intrinsic_len_ (ffebld_left (expr));
6665
6666         if (length == error_mark_node)
6667           break;
6668
6669         if (start == NULL)
6670           {
6671             if (end == NULL)
6672               ;
6673             else
6674               {
6675                 length = convert (ffecom_f2c_ftnlen_type_node,
6676                                   ffecom_expr (end));
6677               }
6678           }
6679         else
6680           {
6681             start_tree = convert (ffecom_f2c_ftnlen_type_node,
6682                                   ffecom_expr (start));
6683
6684             if (start_tree == error_mark_node)
6685               {
6686                 length = error_mark_node;
6687                 break;
6688               }
6689
6690             if (end == NULL)
6691               {
6692                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6693                                    ffecom_f2c_ftnlen_one_node,
6694                                    ffecom_2 (MINUS_EXPR,
6695                                              ffecom_f2c_ftnlen_type_node,
6696                                              length,
6697                                              start_tree));
6698               }
6699             else
6700               {
6701                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
6702                                     ffecom_expr (end));
6703
6704                 if (end_tree == error_mark_node)
6705                   {
6706                     length = error_mark_node;
6707                     break;
6708                   }
6709
6710                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6711                                    ffecom_f2c_ftnlen_one_node,
6712                                    ffecom_2 (MINUS_EXPR,
6713                                              ffecom_f2c_ftnlen_type_node,
6714                                              end_tree, start_tree));
6715               }
6716           }
6717       }
6718       break;
6719
6720     case FFEBLD_opCONCATENATE:
6721       length
6722         = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6723                     ffecom_intrinsic_len_ (ffebld_left (expr)),
6724                     ffecom_intrinsic_len_ (ffebld_right (expr)));
6725       break;
6726
6727     case FFEBLD_opFUNCREF:
6728     case FFEBLD_opCONVERT:
6729       length = build_int_2 (ffebld_size (expr), 0);
6730       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6731       break;
6732
6733     default:
6734       assert ("bad op for single char arg expr" == NULL);
6735       length = ffecom_f2c_ftnlen_zero_node;
6736       break;
6737     }
6738
6739   assert (length != NULL_TREE);
6740
6741   return length;
6742 }
6743
6744 #endif
6745 /* Handle CHARACTER assignments.
6746
6747    Generates code to do the assignment.  Used by ordinary assignment
6748    statement handler ffecom_let_stmt and by statement-function
6749    handler to generate code for a statement function.  */
6750
6751 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6752 static void
6753 ffecom_let_char_ (tree dest_tree, tree dest_length,
6754                   ffetargetCharacterSize dest_size, ffebld source)
6755 {
6756   ffecomConcatList_ catlist;
6757   tree source_length;
6758   tree source_tree;
6759   tree expr_tree;
6760
6761   if ((dest_tree == error_mark_node)
6762       || (dest_length == error_mark_node))
6763     return;
6764
6765   assert (dest_tree != NULL_TREE);
6766   assert (dest_length != NULL_TREE);
6767
6768   /* Source might be an opCONVERT, which just means it is a different size
6769      than the destination.  Since the underlying implementation here handles
6770      that (directly or via the s_copy or s_cat run-time-library functions),
6771      we don't need the "convenience" of an opCONVERT that tells us to
6772      truncate or blank-pad, particularly since the resulting implementation
6773      would probably be slower than otherwise. */
6774
6775   while (ffebld_op (source) == FFEBLD_opCONVERT)
6776     source = ffebld_left (source);
6777
6778   catlist = ffecom_concat_list_new_ (source, dest_size);
6779   switch (ffecom_concat_list_count_ (catlist))
6780     {
6781     case 0:                     /* Shouldn't happen, but in case it does... */
6782       ffecom_concat_list_kill_ (catlist);
6783       source_tree = null_pointer_node;
6784       source_length = ffecom_f2c_ftnlen_zero_node;
6785       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6786       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6787       TREE_CHAIN (TREE_CHAIN (expr_tree))
6788         = build_tree_list (NULL_TREE, dest_length);
6789       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6790         = build_tree_list (NULL_TREE, source_length);
6791
6792       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6793       TREE_SIDE_EFFECTS (expr_tree) = 1;
6794
6795       expand_expr_stmt (expr_tree);
6796
6797       return;
6798
6799     case 1:                     /* The (fairly) easy case. */
6800       ffecom_char_args_ (&source_tree, &source_length,
6801                          ffecom_concat_list_expr_ (catlist, 0));
6802       ffecom_concat_list_kill_ (catlist);
6803       assert (source_tree != NULL_TREE);
6804       assert (source_length != NULL_TREE);
6805
6806       if ((source_tree == error_mark_node)
6807           || (source_length == error_mark_node))
6808         return;
6809
6810       if (dest_size == 1)
6811         {
6812           dest_tree
6813             = ffecom_1 (INDIRECT_REF,
6814                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6815                                                       (dest_tree))),
6816                         dest_tree);
6817           dest_tree
6818             = ffecom_2 (ARRAY_REF,
6819                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6820                                                       (dest_tree))),
6821                         dest_tree,
6822                         integer_one_node);
6823           source_tree
6824             = ffecom_1 (INDIRECT_REF,
6825                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6826                                                       (source_tree))),
6827                         source_tree);
6828           source_tree
6829             = ffecom_2 (ARRAY_REF,
6830                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6831                                                       (source_tree))),
6832                         source_tree,
6833                         integer_one_node);
6834
6835           expr_tree = ffecom_modify (void_type_node, dest_tree, source_tree);
6836
6837           expand_expr_stmt (expr_tree);
6838
6839           return;
6840         }
6841
6842       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6843       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6844       TREE_CHAIN (TREE_CHAIN (expr_tree))
6845         = build_tree_list (NULL_TREE, dest_length);
6846       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6847         = build_tree_list (NULL_TREE, source_length);
6848
6849       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6850       TREE_SIDE_EFFECTS (expr_tree) = 1;
6851
6852       expand_expr_stmt (expr_tree);
6853
6854       return;
6855
6856     default:                    /* Must actually concatenate things. */
6857       break;
6858     }
6859
6860   /* Heavy-duty concatenation. */
6861
6862   {
6863     int count = ffecom_concat_list_count_ (catlist);
6864     int i;
6865     tree lengths;
6866     tree items;
6867     tree length_array;
6868     tree item_array;
6869     tree citem;
6870     tree clength;
6871
6872 #ifdef HOHO
6873     length_array
6874       = lengths
6875       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
6876                              FFETARGET_charactersizeNONE, count, TRUE);
6877     item_array = items = ffecom_push_tempvar (ffecom_f2c_address_type_node,
6878                                               FFETARGET_charactersizeNONE,
6879                                               count, TRUE);
6880 #else
6881     {
6882       tree hook;
6883
6884       hook = ffebld_nonter_hook (source);
6885       assert (hook);
6886       assert (TREE_CODE (hook) == TREE_VEC);
6887       assert (TREE_VEC_LENGTH (hook) == 2);
6888       length_array = lengths = TREE_VEC_ELT (hook, 0);
6889       item_array = items = TREE_VEC_ELT (hook, 1);
6890     }
6891 #endif
6892
6893     for (i = 0; i < count; ++i)
6894       {
6895         ffecom_char_args_ (&citem, &clength,
6896                            ffecom_concat_list_expr_ (catlist, i));
6897         if ((citem == error_mark_node)
6898             || (clength == error_mark_node))
6899           {
6900             ffecom_concat_list_kill_ (catlist);
6901             return;
6902           }
6903
6904         items
6905           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
6906                       ffecom_modify (void_type_node,
6907                                      ffecom_2 (ARRAY_REF,
6908                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
6909                                                item_array,
6910                                                build_int_2 (i, 0)),
6911                                      citem),
6912                       items);
6913         lengths
6914           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
6915                       ffecom_modify (void_type_node,
6916                                      ffecom_2 (ARRAY_REF,
6917                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
6918                                                length_array,
6919                                                build_int_2 (i, 0)),
6920                                      clength),
6921                       lengths);
6922       }
6923
6924     expr_tree = build_tree_list (NULL_TREE, dest_tree);
6925     TREE_CHAIN (expr_tree)
6926       = build_tree_list (NULL_TREE,
6927                          ffecom_1 (ADDR_EXPR,
6928                                    build_pointer_type (TREE_TYPE (items)),
6929                                    items));
6930     TREE_CHAIN (TREE_CHAIN (expr_tree))
6931       = build_tree_list (NULL_TREE,
6932                          ffecom_1 (ADDR_EXPR,
6933                                    build_pointer_type (TREE_TYPE (lengths)),
6934                                    lengths));
6935     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6936       = build_tree_list
6937         (NULL_TREE,
6938          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
6939                    convert (ffecom_f2c_ftnlen_type_node,
6940                             build_int_2 (count, 0))));
6941     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))))
6942       = build_tree_list (NULL_TREE, dest_length);
6943
6944     expr_tree = ffecom_call_gfrt (FFECOM_gfrtCAT, expr_tree, NULL_TREE);
6945     TREE_SIDE_EFFECTS (expr_tree) = 1;
6946
6947     expand_expr_stmt (expr_tree);
6948   }
6949
6950   ffecom_concat_list_kill_ (catlist);
6951 }
6952
6953 #endif
6954 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
6955
6956    ffecomGfrt ix;
6957    ffecom_make_gfrt_(ix);
6958
6959    Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
6960    for the indicated run-time routine (ix).  */
6961
6962 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6963 static void
6964 ffecom_make_gfrt_ (ffecomGfrt ix)
6965 {
6966   tree t;
6967   tree ttype;
6968
6969   switch (ffecom_gfrt_type_[ix])
6970     {
6971     case FFECOM_rttypeVOID_:
6972       ttype = void_type_node;
6973       break;
6974
6975     case FFECOM_rttypeVOIDSTAR_:
6976       ttype = TREE_TYPE (null_pointer_node);    /* `void *'. */
6977       break;
6978
6979     case FFECOM_rttypeFTNINT_:
6980       ttype = ffecom_f2c_ftnint_type_node;
6981       break;
6982
6983     case FFECOM_rttypeINTEGER_:
6984       ttype = ffecom_f2c_integer_type_node;
6985       break;
6986
6987     case FFECOM_rttypeLONGINT_:
6988       ttype = ffecom_f2c_longint_type_node;
6989       break;
6990
6991     case FFECOM_rttypeLOGICAL_:
6992       ttype = ffecom_f2c_logical_type_node;
6993       break;
6994
6995     case FFECOM_rttypeREAL_F2C_:
6996       ttype = double_type_node;
6997       break;
6998
6999     case FFECOM_rttypeREAL_GNU_:
7000       ttype = float_type_node;
7001       break;
7002
7003     case FFECOM_rttypeCOMPLEX_F2C_:
7004       ttype = void_type_node;
7005       break;
7006
7007     case FFECOM_rttypeCOMPLEX_GNU_:
7008       ttype = ffecom_f2c_complex_type_node;
7009       break;
7010
7011     case FFECOM_rttypeDOUBLE_:
7012       ttype = double_type_node;
7013       break;
7014
7015     case FFECOM_rttypeDOUBLEREAL_:
7016       ttype = ffecom_f2c_doublereal_type_node;
7017       break;
7018
7019     case FFECOM_rttypeDBLCMPLX_F2C_:
7020       ttype = void_type_node;
7021       break;
7022
7023     case FFECOM_rttypeDBLCMPLX_GNU_:
7024       ttype = ffecom_f2c_doublecomplex_type_node;
7025       break;
7026
7027     case FFECOM_rttypeCHARACTER_:
7028       ttype = void_type_node;
7029       break;
7030
7031     default:
7032       ttype = NULL;
7033       assert ("bad rttype" == NULL);
7034       break;
7035     }
7036
7037   ttype = build_function_type (ttype, NULL_TREE);
7038   t = build_decl (FUNCTION_DECL,
7039                   get_identifier (ffecom_gfrt_name_[ix]),
7040                   ttype);
7041   DECL_EXTERNAL (t) = 1;
7042   TREE_READONLY (t) = ffecom_gfrt_const_[ix] ? 1 : 0;
7043   TREE_PUBLIC (t) = 1;
7044   TREE_THIS_VOLATILE (t) = ffecom_gfrt_volatile_[ix] ? 1 : 0;
7045
7046   /* Sanity check:  A function that's const cannot be volatile.  */
7047
7048   assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_volatile_[ix] : 1);
7049
7050   /* Sanity check: A function that's const cannot return complex.  */
7051
7052   assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_complex_[ix] : 1);
7053
7054   t = start_decl (t, TRUE);
7055
7056   finish_decl (t, NULL_TREE, TRUE);
7057
7058   ffecom_gfrt_[ix] = t;
7059 }
7060
7061 #endif
7062 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group.  */
7063
7064 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7065 static void
7066 ffecom_member_phase1_ (ffestorag mst UNUSED, ffestorag st)
7067 {
7068   ffesymbol s = ffestorag_symbol (st);
7069
7070   if (ffesymbol_namelisted (s))
7071     ffecom_member_namelisted_ = TRUE;
7072 }
7073
7074 #endif
7075 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group.  Declare
7076    the member so debugger will see it.  Otherwise nobody should be
7077    referencing the member.  */
7078
7079 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7080 static void
7081 ffecom_member_phase2_ (ffestorag mst, ffestorag st)
7082 {
7083   ffesymbol s;
7084   tree t;
7085   tree mt;
7086   tree type;
7087
7088   if ((mst == NULL)
7089       || ((mt = ffestorag_hook (mst)) == NULL)
7090       || (mt == error_mark_node))
7091     return;
7092
7093   if ((st == NULL)
7094       || ((s = ffestorag_symbol (st)) == NULL))
7095     return;
7096
7097   type = ffecom_type_localvar_ (s,
7098                                 ffesymbol_basictype (s),
7099                                 ffesymbol_kindtype (s));
7100   if (type == error_mark_node)
7101     return;
7102
7103   t = build_decl (VAR_DECL,
7104                   ffecom_get_identifier_ (ffesymbol_text (s)),
7105                   type);
7106
7107   TREE_STATIC (t) = TREE_STATIC (mt);
7108   DECL_INITIAL (t) = NULL_TREE;
7109   TREE_ASM_WRITTEN (t) = 1;
7110   TREE_USED (t) = 1;
7111
7112   DECL_RTL (t)
7113     = gen_rtx (MEM, TYPE_MODE (type),
7114                plus_constant (XEXP (DECL_RTL (mt), 0),
7115                               ffestorag_modulo (mst)
7116                               + ffestorag_offset (st)
7117                               - ffestorag_offset (mst)));
7118
7119   t = start_decl (t, FALSE);
7120
7121   finish_decl (t, NULL_TREE, FALSE);
7122 }
7123
7124 #endif
7125 /* Prepare source expression for assignment into a destination perhaps known
7126    to be of a specific size.  */
7127
7128 static void
7129 ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size, ffebld source)
7130 {
7131   ffecomConcatList_ catlist;
7132   int count;
7133   int i;
7134   tree ltmp;
7135   tree itmp;
7136   tree tempvar = NULL_TREE;
7137
7138   while (ffebld_op (source) == FFEBLD_opCONVERT)
7139     source = ffebld_left (source);
7140
7141   catlist = ffecom_concat_list_new_ (source, dest_size);
7142   count = ffecom_concat_list_count_ (catlist);
7143
7144   if (count >= 2)
7145     {
7146       ltmp
7147         = ffecom_make_tempvar ("let_char_len", ffecom_f2c_ftnlen_type_node,
7148                                FFETARGET_charactersizeNONE, count);
7149       itmp
7150         = ffecom_make_tempvar ("let_char_item", ffecom_f2c_address_type_node,
7151                                FFETARGET_charactersizeNONE, count);
7152
7153       tempvar = make_tree_vec (2);
7154       TREE_VEC_ELT (tempvar, 0) = ltmp;
7155       TREE_VEC_ELT (tempvar, 1) = itmp;
7156     }
7157
7158   for (i = 0; i < count; ++i)
7159     ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist, i));
7160
7161   ffecom_concat_list_kill_ (catlist);
7162
7163   if (tempvar)
7164     {
7165       ffebld_nonter_set_hook (source, tempvar);
7166       current_binding_level->prep_state = 1;
7167     }
7168 }
7169
7170 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
7171
7172    Ignores STAR (alternate-return) dummies.  All other get exec-transitioned
7173    (which generates their trees) and then their trees get push_parm_decl'd.
7174
7175    The second arg is TRUE if the dummies are for a statement function, in
7176    which case lengths are not pushed for character arguments (since they are
7177    always known by both the caller and the callee, though the code allows
7178    for someday permitting CHAR*(*) stmtfunc dummies).  */
7179
7180 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7181 static void
7182 ffecom_push_dummy_decls_ (ffebld dummy_list, bool stmtfunc)
7183 {
7184   ffebld dummy;
7185   ffebld dumlist;
7186   ffesymbol s;
7187   tree parm;
7188
7189   ffecom_transform_only_dummies_ = TRUE;
7190
7191   /* First push the parms corresponding to actual dummy "contents".  */
7192
7193   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7194     {
7195       dummy = ffebld_head (dumlist);
7196       switch (ffebld_op (dummy))
7197         {
7198         case FFEBLD_opSTAR:
7199         case FFEBLD_opANY:
7200           continue;             /* Forget alternate returns. */
7201
7202         default:
7203           break;
7204         }
7205       assert (ffebld_op (dummy) == FFEBLD_opSYMTER);
7206       s = ffebld_symter (dummy);
7207       parm = ffesymbol_hook (s).decl_tree;
7208       if (parm == NULL_TREE)
7209         {
7210           s = ffecom_sym_transform_ (s);
7211           parm = ffesymbol_hook (s).decl_tree;
7212           assert (parm != NULL_TREE);
7213         }
7214       if (parm != error_mark_node)
7215         push_parm_decl (parm);
7216     }
7217
7218   /* Then, for CHARACTER dummies, push the parms giving their lengths.  */
7219
7220   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7221     {
7222       dummy = ffebld_head (dumlist);
7223       switch (ffebld_op (dummy))
7224         {
7225         case FFEBLD_opSTAR:
7226         case FFEBLD_opANY:
7227           continue;             /* Forget alternate returns, they mean
7228                                    NOTHING! */
7229
7230         default:
7231           break;
7232         }
7233       s = ffebld_symter (dummy);
7234       if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
7235         continue;               /* Only looking for CHARACTER arguments. */
7236       if (stmtfunc && (ffesymbol_size (s) != FFETARGET_charactersizeNONE))
7237         continue;               /* Stmtfunc arg with known size needs no
7238                                    length param. */
7239       if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
7240         continue;               /* Only looking for variables and arrays. */
7241       parm = ffesymbol_hook (s).length_tree;
7242       assert (parm != NULL_TREE);
7243       if (parm != error_mark_node)
7244         push_parm_decl (parm);
7245     }
7246
7247   ffecom_transform_only_dummies_ = FALSE;
7248 }
7249
7250 #endif
7251 /* ffecom_start_progunit_ -- Beginning of program unit
7252
7253    Does GNU back end stuff necessary to teach it about the start of its
7254    equivalent of a Fortran program unit.  */
7255
7256 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7257 static void
7258 ffecom_start_progunit_ ()
7259 {
7260   ffesymbol fn = ffecom_primary_entry_;
7261   ffebld arglist;
7262   tree id;                      /* Identifier (name) of function. */
7263   tree type;                    /* Type of function. */
7264   tree result;                  /* Result of function. */
7265   ffeinfoBasictype bt;
7266   ffeinfoKindtype kt;
7267   ffeglobal g;
7268   ffeglobalType gt;
7269   ffeglobalType egt = FFEGLOBAL_type;
7270   bool charfunc;
7271   bool cmplxfunc;
7272   bool altentries = (ffecom_num_entrypoints_ != 0);
7273   bool multi
7274   = altentries
7275   && (ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
7276   && (ffecom_master_bt_ == FFEINFO_basictypeNONE);
7277   bool main_program = FALSE;
7278   int old_lineno = lineno;
7279   const char *old_input_filename = input_filename;
7280
7281   assert (fn != NULL);
7282   assert (ffesymbol_hook (fn).decl_tree == NULL_TREE);
7283
7284   input_filename = ffesymbol_where_filename (fn);
7285   lineno = ffesymbol_where_filelinenum (fn);
7286
7287   switch (ffecom_primary_entry_kind_)
7288     {
7289     case FFEINFO_kindPROGRAM:
7290       main_program = TRUE;
7291       gt = FFEGLOBAL_typeMAIN;
7292       bt = FFEINFO_basictypeNONE;
7293       kt = FFEINFO_kindtypeNONE;
7294       type = ffecom_tree_fun_type_void;
7295       charfunc = FALSE;
7296       cmplxfunc = FALSE;
7297       break;
7298
7299     case FFEINFO_kindBLOCKDATA:
7300       gt = FFEGLOBAL_typeBDATA;
7301       bt = FFEINFO_basictypeNONE;
7302       kt = FFEINFO_kindtypeNONE;
7303       type = ffecom_tree_fun_type_void;
7304       charfunc = FALSE;
7305       cmplxfunc = FALSE;
7306       break;
7307
7308     case FFEINFO_kindFUNCTION:
7309       gt = FFEGLOBAL_typeFUNC;
7310       egt = FFEGLOBAL_typeEXT;
7311       bt = ffesymbol_basictype (fn);
7312       kt = ffesymbol_kindtype (fn);
7313       if (bt == FFEINFO_basictypeNONE)
7314         {
7315           ffeimplic_establish_symbol (fn);
7316           if (ffesymbol_funcresult (fn) != NULL)
7317             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
7318           bt = ffesymbol_basictype (fn);
7319           kt = ffesymbol_kindtype (fn);
7320         }
7321
7322       if (multi)
7323         charfunc = cmplxfunc = FALSE;
7324       else if (bt == FFEINFO_basictypeCHARACTER)
7325         charfunc = TRUE, cmplxfunc = FALSE;
7326       else if ((bt == FFEINFO_basictypeCOMPLEX)
7327                && ffesymbol_is_f2c (fn)
7328                && !altentries)
7329         charfunc = FALSE, cmplxfunc = TRUE;
7330       else
7331         charfunc = cmplxfunc = FALSE;
7332
7333       if (multi || charfunc)
7334         type = ffecom_tree_fun_type_void;
7335       else if (ffesymbol_is_f2c (fn) && !altentries)
7336         type = ffecom_tree_fun_type[bt][kt];
7337       else
7338         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
7339
7340       if ((type == NULL_TREE)
7341           || (TREE_TYPE (type) == NULL_TREE))
7342         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
7343       break;
7344
7345     case FFEINFO_kindSUBROUTINE:
7346       gt = FFEGLOBAL_typeSUBR;
7347       egt = FFEGLOBAL_typeEXT;
7348       bt = FFEINFO_basictypeNONE;
7349       kt = FFEINFO_kindtypeNONE;
7350       if (ffecom_is_altreturning_)
7351         type = ffecom_tree_subr_type;
7352       else
7353         type = ffecom_tree_fun_type_void;
7354       charfunc = FALSE;
7355       cmplxfunc = FALSE;
7356       break;
7357
7358     default:
7359       assert ("say what??" == NULL);
7360       /* Fall through. */
7361     case FFEINFO_kindANY:
7362       gt = FFEGLOBAL_typeANY;
7363       bt = FFEINFO_basictypeNONE;
7364       kt = FFEINFO_kindtypeNONE;
7365       type = error_mark_node;
7366       charfunc = FALSE;
7367       cmplxfunc = FALSE;
7368       break;
7369     }
7370
7371   if (altentries)
7372     {
7373       id = ffecom_get_invented_identifier ("__g77_masterfun_%s",
7374                                            ffesymbol_text (fn));
7375     }
7376 #if FFETARGET_isENFORCED_MAIN
7377   else if (main_program)
7378     id = get_identifier (FFETARGET_nameENFORCED_MAIN_NAME);
7379 #endif
7380   else
7381     id = ffecom_get_external_identifier_ (fn);
7382
7383   start_function (id,
7384                   type,
7385                   0,            /* nested/inline */
7386                   !altentries); /* TREE_PUBLIC */
7387
7388   TREE_USED (current_function_decl) = 1;        /* Avoid spurious warning if altentries. */
7389
7390   if (!altentries
7391       && ((g = ffesymbol_global (fn)) != NULL)
7392       && ((ffeglobal_type (g) == gt)
7393           || (ffeglobal_type (g) == egt)))
7394     {
7395       ffeglobal_set_hook (g, current_function_decl);
7396     }
7397
7398   /* Arg handling needs exec-transitioned ffesymbols to work with.  But
7399      exec-transitioning needs current_function_decl to be filled in.  So we
7400      do these things in two phases. */
7401
7402   if (altentries)
7403     {                           /* 1st arg identifies which entrypoint. */
7404       ffecom_which_entrypoint_decl_
7405         = build_decl (PARM_DECL,
7406                       ffecom_get_invented_identifier ("__g77_%s",
7407                                                       "which_entrypoint"),
7408                       integer_type_node);
7409       push_parm_decl (ffecom_which_entrypoint_decl_);
7410     }
7411
7412   if (charfunc
7413       || cmplxfunc
7414       || multi)
7415     {                           /* Arg for result (return value). */
7416       tree type;
7417       tree length;
7418
7419       if (charfunc)
7420         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
7421       else if (cmplxfunc)
7422         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
7423       else
7424         type = ffecom_multi_type_node_;
7425
7426       result = ffecom_get_invented_identifier ("__g77_%s", "result");
7427
7428       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
7429
7430       if (charfunc)
7431         length = ffecom_char_enhance_arg_ (&type, fn);
7432       else
7433         length = NULL_TREE;     /* Not ref'd if !charfunc. */
7434
7435       type = build_pointer_type (type);
7436       result = build_decl (PARM_DECL, result, type);
7437
7438       push_parm_decl (result);
7439       if (multi)
7440         ffecom_multi_retval_ = result;
7441       else
7442         ffecom_func_result_ = result;
7443
7444       if (charfunc)
7445         {
7446           push_parm_decl (length);
7447           ffecom_func_length_ = length;
7448         }
7449     }
7450
7451   if (ffecom_primary_entry_is_proc_)
7452     {
7453       if (altentries)
7454         arglist = ffecom_master_arglist_;
7455       else
7456         arglist = ffesymbol_dummyargs (fn);
7457       ffecom_push_dummy_decls_ (arglist, FALSE);
7458     }
7459
7460   if (TREE_CODE (current_function_decl) != ERROR_MARK)
7461     store_parm_decls (main_program ? 1 : 0);
7462
7463   ffecom_start_compstmt ();
7464   /* Disallow temp vars at this level.  */
7465   current_binding_level->prep_state = 2;
7466
7467   lineno = old_lineno;
7468   input_filename = old_input_filename;
7469
7470   /* This handles any symbols still untransformed, in case -g specified.
7471      This used to be done in ffecom_finish_progunit, but it turns out to
7472      be necessary to do it here so that statement functions are
7473      expanded before code.  But don't bother for BLOCK DATA.  */
7474
7475   if (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
7476     ffesymbol_drive (ffecom_finish_symbol_transform_);
7477 }
7478
7479 #endif
7480 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
7481
7482    ffesymbol s;
7483    ffecom_sym_transform_(s);
7484
7485    The ffesymbol_hook info for s is updated with appropriate backend info
7486    on the symbol.  */
7487
7488 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7489 static ffesymbol
7490 ffecom_sym_transform_ (ffesymbol s)
7491 {
7492   tree t;                       /* Transformed thingy. */
7493   tree tlen;                    /* Length if CHAR*(*). */
7494   bool addr;                    /* Is t the address of the thingy? */
7495   ffeinfoBasictype bt;
7496   ffeinfoKindtype kt;
7497   ffeglobal g;
7498   int old_lineno = lineno;
7499   const char *old_input_filename = input_filename;
7500
7501   /* Must ensure special ASSIGN variables are declared at top of outermost
7502      block, else they'll end up in the innermost block when their first
7503      ASSIGN is seen, which leaves them out of scope when they're the
7504      subject of a GOTO or I/O statement.
7505
7506      We make this variable even if -fugly-assign.  Just let it go unused,
7507      in case it turns out there are cases where we really want to use this
7508      variable anyway (e.g. ASSIGN to INTEGER*2 variable).  */
7509
7510   if (! ffecom_transform_only_dummies_
7511       && ffesymbol_assigned (s)
7512       && ! ffesymbol_hook (s).assign_tree)
7513     s = ffecom_sym_transform_assign_ (s);
7514
7515   if (ffesymbol_sfdummyparent (s) == NULL)
7516     {
7517       input_filename = ffesymbol_where_filename (s);
7518       lineno = ffesymbol_where_filelinenum (s);
7519     }
7520   else
7521     {
7522       ffesymbol sf = ffesymbol_sfdummyparent (s);
7523
7524       input_filename = ffesymbol_where_filename (sf);
7525       lineno = ffesymbol_where_filelinenum (sf);
7526     }
7527
7528   bt = ffeinfo_basictype (ffebld_info (s));
7529   kt = ffeinfo_kindtype (ffebld_info (s));
7530
7531   t = NULL_TREE;
7532   tlen = NULL_TREE;
7533   addr = FALSE;
7534
7535   switch (ffesymbol_kind (s))
7536     {
7537     case FFEINFO_kindNONE:
7538       switch (ffesymbol_where (s))
7539         {
7540         case FFEINFO_whereDUMMY:        /* Subroutine or function. */
7541           assert (ffecom_transform_only_dummies_);
7542
7543           /* Before 0.4, this could be ENTITY/DUMMY, but see
7544              ffestu_sym_end_transition -- no longer true (in particular, if
7545              it could be an ENTITY, it _will_ be made one, so that
7546              possibility won't come through here).  So we never make length
7547              arg for CHARACTER type.  */
7548
7549           t = build_decl (PARM_DECL,
7550                           ffecom_get_identifier_ (ffesymbol_text (s)),
7551                           ffecom_tree_ptr_to_subr_type);
7552 #if BUILT_FOR_270
7553           DECL_ARTIFICIAL (t) = 1;
7554 #endif
7555           addr = TRUE;
7556           break;
7557
7558         case FFEINFO_whereGLOBAL:       /* Subroutine or function. */
7559           assert (!ffecom_transform_only_dummies_);
7560
7561           if (((g = ffesymbol_global (s)) != NULL)
7562               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7563                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7564                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
7565               && (ffeglobal_hook (g) != NULL_TREE)
7566               && ffe_is_globals ())
7567             {
7568               t = ffeglobal_hook (g);
7569               break;
7570             }
7571
7572           t = build_decl (FUNCTION_DECL,
7573                           ffecom_get_external_identifier_ (s),
7574                           ffecom_tree_subr_type);       /* Assume subr. */
7575           DECL_EXTERNAL (t) = 1;
7576           TREE_PUBLIC (t) = 1;
7577
7578           t = start_decl (t, FALSE);
7579           finish_decl (t, NULL_TREE, FALSE);
7580
7581           if ((g != NULL)
7582               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7583                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7584                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
7585             ffeglobal_set_hook (g, t);
7586
7587           ffecom_save_tree_forever (t);
7588
7589           break;
7590
7591         default:
7592           assert ("NONE where unexpected" == NULL);
7593           /* Fall through. */
7594         case FFEINFO_whereANY:
7595           break;
7596         }
7597       break;
7598
7599     case FFEINFO_kindENTITY:
7600       switch (ffeinfo_where (ffesymbol_info (s)))
7601         {
7602
7603         case FFEINFO_whereCONSTANT:
7604           /* ~~Debugging info needed? */
7605           assert (!ffecom_transform_only_dummies_);
7606           t = error_mark_node;  /* Shouldn't ever see this in expr. */
7607           break;
7608
7609         case FFEINFO_whereLOCAL:
7610           assert (!ffecom_transform_only_dummies_);
7611
7612           {
7613             ffestorag st = ffesymbol_storage (s);
7614             tree type;
7615
7616             if ((st != NULL)
7617                 && (ffestorag_size (st) == 0))
7618               {
7619                 t = error_mark_node;
7620                 break;
7621               }
7622
7623             type = ffecom_type_localvar_ (s, bt, kt);
7624
7625             if (type == error_mark_node)
7626               {
7627                 t = error_mark_node;
7628                 break;
7629               }
7630
7631             if ((st != NULL)
7632                 && (ffestorag_parent (st) != NULL))
7633               {                 /* Child of EQUIVALENCE parent. */
7634                 ffestorag est;
7635                 tree et;
7636                 ffetargetOffset offset;
7637
7638                 est = ffestorag_parent (st);
7639                 ffecom_transform_equiv_ (est);
7640
7641                 et = ffestorag_hook (est);
7642                 assert (et != NULL_TREE);
7643
7644                 if (! TREE_STATIC (et))
7645                   put_var_into_stack (et);
7646
7647                 offset = ffestorag_modulo (est)
7648                   + ffestorag_offset (ffesymbol_storage (s))
7649                   - ffestorag_offset (est);
7650
7651                 ffecom_debug_kludge_ (et, "EQUIVALENCE", s, type, offset);
7652
7653                 /* (t_type *) (((char *) &et) + offset) */
7654
7655                 t = convert (string_type_node,  /* (char *) */
7656                              ffecom_1 (ADDR_EXPR,
7657                                        build_pointer_type (TREE_TYPE (et)),
7658                                        et));
7659                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
7660                               t,
7661                               build_int_2 (offset, 0));
7662                 t = convert (build_pointer_type (type),
7663                              t);
7664                 TREE_CONSTANT (t) = staticp (et);
7665
7666                 addr = TRUE;
7667               }
7668             else
7669               {
7670                 tree initexpr;
7671                 bool init = ffesymbol_is_init (s);
7672
7673                 t = build_decl (VAR_DECL,
7674                                 ffecom_get_identifier_ (ffesymbol_text (s)),
7675                                 type);
7676
7677                 if (init
7678                     || ffesymbol_namelisted (s)
7679 #ifdef FFECOM_sizeMAXSTACKITEM
7680                     || ((st != NULL)
7681                         && (ffestorag_size (st) > FFECOM_sizeMAXSTACKITEM))
7682 #endif
7683                     || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
7684                         && (ffecom_primary_entry_kind_
7685                             != FFEINFO_kindBLOCKDATA)
7686                         && (ffesymbol_is_save (s) || ffe_is_saveall ())))
7687                   TREE_STATIC (t) = !ffesymbol_attr (s, FFESYMBOL_attrADJUSTABLE);
7688                 else
7689                   TREE_STATIC (t) = 0;  /* No need to make static. */
7690
7691                 if (init || ffe_is_init_local_zero ())
7692                   DECL_INITIAL (t) = error_mark_node;
7693
7694                 /* Keep -Wunused from complaining about var if it
7695                    is used as sfunc arg or DATA implied-DO.  */
7696                 if (ffesymbol_attrs (s) & FFESYMBOL_attrsSFARG)
7697                   DECL_IN_SYSTEM_HEADER (t) = 1;
7698
7699                 t = start_decl (t, FALSE);
7700
7701                 if (init)
7702                   {
7703                     if (ffesymbol_init (s) != NULL)
7704                       initexpr = ffecom_expr (ffesymbol_init (s));
7705                     else
7706                       initexpr = ffecom_init_zero_ (t);
7707                   }
7708                 else if (ffe_is_init_local_zero ())
7709                   initexpr = ffecom_init_zero_ (t);
7710                 else
7711                   initexpr = NULL_TREE; /* Not ref'd if !init. */
7712
7713                 finish_decl (t, initexpr, FALSE);
7714
7715                 if (st != NULL && DECL_SIZE (t) != error_mark_node)
7716                   {
7717                     assert (TREE_CODE (DECL_SIZE_UNIT (t)) == INTEGER_CST);
7718                     assert (0 == compare_tree_int (DECL_SIZE_UNIT (t),
7719                                                    ffestorag_size (st)));
7720                   }
7721               }
7722           }
7723           break;
7724
7725         case FFEINFO_whereRESULT:
7726           assert (!ffecom_transform_only_dummies_);
7727
7728           if (bt == FFEINFO_basictypeCHARACTER)
7729             {                   /* Result is already in list of dummies, use
7730                                    it (& length). */
7731               t = ffecom_func_result_;
7732               tlen = ffecom_func_length_;
7733               addr = TRUE;
7734               break;
7735             }
7736           if ((ffecom_num_entrypoints_ == 0)
7737               && (bt == FFEINFO_basictypeCOMPLEX)
7738               && (ffesymbol_is_f2c (ffecom_primary_entry_)))
7739             {                   /* Result is already in list of dummies, use
7740                                    it. */
7741               t = ffecom_func_result_;
7742               addr = TRUE;
7743               break;
7744             }
7745           if (ffecom_func_result_ != NULL_TREE)
7746             {
7747               t = ffecom_func_result_;
7748               break;
7749             }
7750           if ((ffecom_num_entrypoints_ != 0)
7751               && (ffecom_master_bt_ == FFEINFO_basictypeNONE))
7752             {
7753               assert (ffecom_multi_retval_ != NULL_TREE);
7754               t = ffecom_1 (INDIRECT_REF, ffecom_multi_type_node_,
7755                             ffecom_multi_retval_);
7756               t = ffecom_2 (COMPONENT_REF, ffecom_tree_type[bt][kt],
7757                             t, ffecom_multi_fields_[bt][kt]);
7758
7759               break;
7760             }
7761
7762           t = build_decl (VAR_DECL,
7763                           ffecom_get_identifier_ (ffesymbol_text (s)),
7764                           ffecom_tree_type[bt][kt]);
7765           TREE_STATIC (t) = 0;  /* Put result on stack. */
7766           t = start_decl (t, FALSE);
7767           finish_decl (t, NULL_TREE, FALSE);
7768
7769           ffecom_func_result_ = t;
7770
7771           break;
7772
7773         case FFEINFO_whereDUMMY:
7774           {
7775             tree type;
7776             ffebld dl;
7777             ffebld dim;
7778             tree low;
7779             tree high;
7780             tree old_sizes;
7781             bool adjustable = FALSE;    /* Conditionally adjustable? */
7782
7783             type = ffecom_tree_type[bt][kt];
7784             if (ffesymbol_sfdummyparent (s) != NULL)
7785               {
7786                 if (current_function_decl == ffecom_outer_function_decl_)
7787                   {                     /* Exec transition before sfunc
7788                                            context; get it later. */
7789                     break;
7790                   }
7791                 t = ffecom_get_identifier_ (ffesymbol_text
7792                                             (ffesymbol_sfdummyparent (s)));
7793               }
7794             else
7795               t = ffecom_get_identifier_ (ffesymbol_text (s));
7796
7797             assert (ffecom_transform_only_dummies_);
7798
7799             old_sizes = get_pending_sizes ();
7800             put_pending_sizes (old_sizes);
7801
7802             if (bt == FFEINFO_basictypeCHARACTER)
7803               tlen = ffecom_char_enhance_arg_ (&type, s);
7804             type = ffecom_check_size_overflow_ (s, type, TRUE);
7805
7806             for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
7807               {
7808                 if (type == error_mark_node)
7809                   break;
7810
7811                 dim = ffebld_head (dl);
7812                 assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
7813                 if ((ffebld_left (dim) == NULL) || ffecom_doing_entry_)
7814                   low = ffecom_integer_one_node;
7815                 else
7816                   low = ffecom_expr (ffebld_left (dim));
7817                 assert (ffebld_right (dim) != NULL);
7818                 if ((ffebld_op (ffebld_right (dim)) == FFEBLD_opSTAR)
7819                     || ffecom_doing_entry_)
7820                   {
7821                     /* Used to just do high=low.  But for ffecom_tree_
7822                        canonize_ref_, it probably is important to correctly
7823                        assess the size.  E.g. given COMPLEX C(*),CFUNC and
7824                        C(2)=CFUNC(C), overlap can happen, while it can't
7825                        for, say, C(1)=CFUNC(C(2)).  */
7826                     /* Even more recently used to set to INT_MAX, but that
7827                        broke when some overflow checking went into the back
7828                        end.  Now we just leave the upper bound unspecified.  */
7829                     high = NULL;
7830                   }
7831                 else
7832                   high = ffecom_expr (ffebld_right (dim));
7833
7834                 /* Determine whether array is conditionally adjustable,
7835                    to decide whether back-end magic is needed.
7836
7837                    Normally the front end uses the back-end function
7838                    variable_size to wrap SAVE_EXPR's around expressions
7839                    affecting the size/shape of an array so that the
7840                    size/shape info doesn't change during execution
7841                    of the compiled code even though variables and
7842                    functions referenced in those expressions might.
7843
7844                    variable_size also makes sure those saved expressions
7845                    get evaluated immediately upon entry to the
7846                    compiled procedure -- the front end normally doesn't
7847                    have to worry about that.
7848
7849                    However, there is a problem with this that affects
7850                    g77's implementation of entry points, and that is
7851                    that it is _not_ true that each invocation of the
7852                    compiled procedure is permitted to evaluate
7853                    array size/shape info -- because it is possible
7854                    that, for some invocations, that info is invalid (in
7855                    which case it is "promised" -- i.e. a violation of
7856                    the Fortran standard -- that the compiled code
7857                    won't reference the array or its size/shape
7858                    during that particular invocation).
7859
7860                    To phrase this in C terms, consider this gcc function:
7861
7862                      void foo (int *n, float (*a)[*n])
7863                      {
7864                        // a is "pointer to array ...", fyi.
7865                      }
7866
7867                    Suppose that, for some invocations, it is permitted
7868                    for a caller of foo to do this:
7869
7870                        foo (NULL, NULL);
7871
7872                    Now the _written_ code for foo can take such a call
7873                    into account by either testing explicitly for whether
7874                    (a == NULL) || (n == NULL) -- presumably it is
7875                    not permitted to reference *a in various fashions
7876                    if (n == NULL) I suppose -- or it can avoid it by
7877                    looking at other info (other arguments, static/global
7878                    data, etc.).
7879
7880                    However, this won't work in gcc 2.5.8 because it'll
7881                    automatically emit the code to save the "*n"
7882                    expression, which'll yield a NULL dereference for
7883                    the "foo (NULL, NULL)" call, something the code
7884                    for foo cannot prevent.
7885
7886                    g77 definitely needs to avoid executing such
7887                    code anytime the pointer to the adjustable array
7888                    is NULL, because even if its bounds expressions
7889                    don't have any references to possible "absent"
7890                    variables like "*n" -- say all variable references
7891                    are to COMMON variables, i.e. global (though in C,
7892                    local static could actually make sense) -- the
7893                    expressions could yield other run-time problems
7894                    for allowably "dead" values in those variables.
7895
7896                    For example, let's consider a more complicated
7897                    version of foo:
7898
7899                      extern int i;
7900                      extern int j;
7901
7902                      void foo (float (*a)[i/j])
7903                      {
7904                        ...
7905                      }
7906
7907                    The above is (essentially) quite valid for Fortran
7908                    but, again, for a call like "foo (NULL);", it is
7909                    permitted for i and j to be undefined when the
7910                    call is made.  If j happened to be zero, for
7911                    example, emitting the code to evaluate "i/j"
7912                    could result in a run-time error.
7913
7914                    Offhand, though I don't have my F77 or F90
7915                    standards handy, it might even be valid for a
7916                    bounds expression to contain a function reference,
7917                    in which case I doubt it is permitted for an
7918                    implementation to invoke that function in the
7919                    Fortran case involved here (invocation of an
7920                    alternate ENTRY point that doesn't have the adjustable
7921                    array as one of its arguments).
7922
7923                    So, the code that the compiler would normally emit
7924                    to preevaluate the size/shape info for an
7925                    adjustable array _must not_ be executed at run time
7926                    in certain cases.  Specifically, for Fortran,
7927                    the case is when the pointer to the adjustable
7928                    array == NULL.  (For gnu-ish C, it might be nice
7929                    for the source code itself to specify an expression
7930                    that, if TRUE, inhibits execution of the code.  Or
7931                    reverse the sense for elegance.)
7932
7933                    (Note that g77 could use a different test than NULL,
7934                    actually, since it happens to always pass an
7935                    integer to the called function that specifies which
7936                    entry point is being invoked.  Hmm, this might
7937                    solve the next problem.)
7938
7939                    One way a user could, I suppose, write "foo" so
7940                    it works is to insert COND_EXPR's for the
7941                    size/shape info so the dangerous stuff isn't
7942                    actually done, as in:
7943
7944                      void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
7945                      {
7946                        ...
7947                      }
7948
7949                    The next problem is that the front end needs to
7950                    be able to tell the back end about the array's
7951                    decl _before_ it tells it about the conditional
7952                    expression to inhibit evaluation of size/shape info,
7953                    as shown above.
7954
7955                    To solve this, the front end needs to be able
7956                    to give the back end the expression to inhibit
7957                    generation of the preevaluation code _after_
7958                    it makes the decl for the adjustable array.
7959
7960                    Until then, the above example using the COND_EXPR
7961                    doesn't pass muster with gcc because the "(a == NULL)"
7962                    part has a reference to "a", which is still
7963                    undefined at that point.
7964
7965                    g77 will therefore use a different mechanism in the
7966                    meantime.  */
7967
7968                 if (!adjustable
7969                     && ((TREE_CODE (low) != INTEGER_CST)
7970                         || (high && TREE_CODE (high) != INTEGER_CST)))
7971                   adjustable = TRUE;
7972
7973 #if 0                           /* Old approach -- see below. */
7974                 if (TREE_CODE (low) != INTEGER_CST)
7975                   low = ffecom_3 (COND_EXPR, integer_type_node,
7976                                   ffecom_adjarray_passed_ (s),
7977                                   low,
7978                                   ffecom_integer_zero_node);
7979
7980                 if (high && TREE_CODE (high) != INTEGER_CST)
7981                   high = ffecom_3 (COND_EXPR, integer_type_node,
7982                                    ffecom_adjarray_passed_ (s),
7983                                    high,
7984                                    ffecom_integer_zero_node);
7985 #endif
7986
7987                 /* ~~~gcc/stor-layout.c (layout_type) should do this,
7988                    probably.  Fixes 950302-1.f.  */
7989
7990                 if (TREE_CODE (low) != INTEGER_CST)
7991                   low = variable_size (low);
7992
7993                 /* ~~~Similarly, this fixes dumb0.f.  The C front end
7994                    does this, which is why dumb0.c would work.  */
7995
7996                 if (high && TREE_CODE (high) != INTEGER_CST)
7997                   high = variable_size (high);
7998
7999                 type
8000                   = build_array_type
8001                     (type,
8002                      build_range_type (ffecom_integer_type_node,
8003                                        low, high));
8004                 type = ffecom_check_size_overflow_ (s, type, TRUE);
8005               }
8006
8007             if (type == error_mark_node)
8008               {
8009                 t = error_mark_node;
8010                 break;
8011               }
8012
8013             if ((ffesymbol_sfdummyparent (s) == NULL)
8014                  || (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
8015               {
8016                 type = build_pointer_type (type);
8017                 addr = TRUE;
8018               }
8019
8020             t = build_decl (PARM_DECL, t, type);
8021 #if BUILT_FOR_270
8022             DECL_ARTIFICIAL (t) = 1;
8023 #endif
8024
8025             /* If this arg is present in every entry point's list of
8026                dummy args, then we're done.  */
8027
8028             if (ffesymbol_numentries (s)
8029                 == (ffecom_num_entrypoints_ + 1))
8030               break;
8031
8032 #if 1
8033
8034             /* If variable_size in stor-layout has been called during
8035                the above, then get_pending_sizes should have the
8036                yet-to-be-evaluated saved expressions pending.
8037                Make the whole lot of them get emitted, conditionally
8038                on whether the array decl ("t" above) is not NULL.  */
8039
8040             {
8041               tree sizes = get_pending_sizes ();
8042               tree tem;
8043
8044               for (tem = sizes;
8045                    tem != old_sizes;
8046                    tem = TREE_CHAIN (tem))
8047                 {
8048                   tree temv = TREE_VALUE (tem);
8049
8050                   if (sizes == tem)
8051                     sizes = temv;
8052                   else
8053                     sizes
8054                       = ffecom_2 (COMPOUND_EXPR,
8055                                   TREE_TYPE (sizes),
8056                                   temv,
8057                                   sizes);
8058                 }
8059
8060               if (sizes != tem)
8061                 {
8062                   sizes
8063                     = ffecom_3 (COND_EXPR,
8064                                 TREE_TYPE (sizes),
8065                                 ffecom_2 (NE_EXPR,
8066                                           integer_type_node,
8067                                           t,
8068                                           null_pointer_node),
8069                                 sizes,
8070                                 convert (TREE_TYPE (sizes),
8071                                          integer_zero_node));
8072                   sizes = ffecom_save_tree (sizes);
8073
8074                   sizes
8075                     = tree_cons (NULL_TREE, sizes, tem);
8076                 }
8077
8078               if (sizes)
8079                 put_pending_sizes (sizes);
8080             }
8081
8082 #else
8083 #if 0
8084             if (adjustable
8085                 && (ffesymbol_numentries (s)
8086                     != ffecom_num_entrypoints_ + 1))
8087               DECL_SOMETHING (t)
8088                 = ffecom_2 (NE_EXPR, integer_type_node,
8089                             t,
8090                             null_pointer_node);
8091 #else
8092 #if 0
8093             if (adjustable
8094                 && (ffesymbol_numentries (s)
8095                     != ffecom_num_entrypoints_ + 1))
8096               {
8097                 ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED);
8098                 ffebad_here (0, ffesymbol_where_line (s),
8099                              ffesymbol_where_column (s));
8100                 ffebad_string (ffesymbol_text (s));
8101                 ffebad_finish ();
8102               }
8103 #endif
8104 #endif
8105 #endif
8106           }
8107           break;
8108
8109         case FFEINFO_whereCOMMON:
8110           {
8111             ffesymbol cs;
8112             ffeglobal cg;
8113             tree ct;
8114             ffestorag st = ffesymbol_storage (s);
8115             tree type;
8116
8117             cs = ffesymbol_common (s);  /* The COMMON area itself.  */
8118             if (st != NULL)     /* Else not laid out. */
8119               {
8120                 ffecom_transform_common_ (cs);
8121                 st = ffesymbol_storage (s);
8122               }
8123
8124             type = ffecom_type_localvar_ (s, bt, kt);
8125
8126             cg = ffesymbol_global (cs); /* The global COMMON info.  */
8127             if ((cg == NULL)
8128                 || (ffeglobal_type (cg) != FFEGLOBAL_typeCOMMON))
8129               ct = NULL_TREE;
8130             else
8131               ct = ffeglobal_hook (cg); /* The common area's tree.  */
8132
8133             if ((ct == NULL_TREE)
8134                 || (st == NULL)
8135                 || (type == error_mark_node))
8136               t = error_mark_node;
8137             else
8138               {
8139                 ffetargetOffset offset;
8140                 ffestorag cst;
8141
8142                 cst = ffestorag_parent (st);
8143                 assert (cst == ffesymbol_storage (cs));
8144
8145                 offset = ffestorag_modulo (cst)
8146                   + ffestorag_offset (st)
8147                   - ffestorag_offset (cst);
8148
8149                 ffecom_debug_kludge_ (ct, "COMMON", s, type, offset);
8150
8151                 /* (t_type *) (((char *) &ct) + offset) */
8152
8153                 t = convert (string_type_node,  /* (char *) */
8154                              ffecom_1 (ADDR_EXPR,
8155                                        build_pointer_type (TREE_TYPE (ct)),
8156                                        ct));
8157                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
8158                               t,
8159                               build_int_2 (offset, 0));
8160                 t = convert (build_pointer_type (type),
8161                              t);
8162                 TREE_CONSTANT (t) = 1;
8163
8164                 addr = TRUE;
8165               }
8166           }
8167           break;
8168
8169         case FFEINFO_whereIMMEDIATE:
8170         case FFEINFO_whereGLOBAL:
8171         case FFEINFO_whereFLEETING:
8172         case FFEINFO_whereFLEETING_CADDR:
8173         case FFEINFO_whereFLEETING_IADDR:
8174         case FFEINFO_whereINTRINSIC:
8175         case FFEINFO_whereCONSTANT_SUBOBJECT:
8176         default:
8177           assert ("ENTITY where unheard of" == NULL);
8178           /* Fall through. */
8179         case FFEINFO_whereANY:
8180           t = error_mark_node;
8181           break;
8182         }
8183       break;
8184
8185     case FFEINFO_kindFUNCTION:
8186       switch (ffeinfo_where (ffesymbol_info (s)))
8187         {
8188         case FFEINFO_whereLOCAL:        /* Me. */
8189           assert (!ffecom_transform_only_dummies_);
8190           t = current_function_decl;
8191           break;
8192
8193         case FFEINFO_whereGLOBAL:
8194           assert (!ffecom_transform_only_dummies_);
8195
8196           if (((g = ffesymbol_global (s)) != NULL)
8197               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8198                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8199               && (ffeglobal_hook (g) != NULL_TREE)
8200               && ffe_is_globals ())
8201             {
8202               t = ffeglobal_hook (g);
8203               break;
8204             }
8205
8206           if (ffesymbol_is_f2c (s)
8207               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8208             t = ffecom_tree_fun_type[bt][kt];
8209           else
8210             t = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
8211
8212           t = build_decl (FUNCTION_DECL,
8213                           ffecom_get_external_identifier_ (s),
8214                           t);
8215           DECL_EXTERNAL (t) = 1;
8216           TREE_PUBLIC (t) = 1;
8217
8218           t = start_decl (t, FALSE);
8219           finish_decl (t, NULL_TREE, FALSE);
8220
8221           if ((g != NULL)
8222               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8223                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8224             ffeglobal_set_hook (g, t);
8225
8226           ffecom_save_tree_forever (t);
8227
8228           break;
8229
8230         case FFEINFO_whereDUMMY:
8231           assert (ffecom_transform_only_dummies_);
8232
8233           if (ffesymbol_is_f2c (s)
8234               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8235             t = ffecom_tree_ptr_to_fun_type[bt][kt];
8236           else
8237             t = build_pointer_type
8238               (build_function_type (ffecom_tree_type[bt][kt], NULL_TREE));
8239
8240           t = build_decl (PARM_DECL,
8241                           ffecom_get_identifier_ (ffesymbol_text (s)),
8242                           t);
8243 #if BUILT_FOR_270
8244           DECL_ARTIFICIAL (t) = 1;
8245 #endif
8246           addr = TRUE;
8247           break;
8248
8249         case FFEINFO_whereCONSTANT:     /* Statement function. */
8250           assert (!ffecom_transform_only_dummies_);
8251           t = ffecom_gen_sfuncdef_ (s, bt, kt);
8252           break;
8253
8254         case FFEINFO_whereINTRINSIC:
8255           assert (!ffecom_transform_only_dummies_);
8256           break;                /* Let actual references generate their
8257                                    decls. */
8258
8259         default:
8260           assert ("FUNCTION where unheard of" == NULL);
8261           /* Fall through. */
8262         case FFEINFO_whereANY:
8263           t = error_mark_node;
8264           break;
8265         }
8266       break;
8267
8268     case FFEINFO_kindSUBROUTINE:
8269       switch (ffeinfo_where (ffesymbol_info (s)))
8270         {
8271         case FFEINFO_whereLOCAL:        /* Me. */
8272           assert (!ffecom_transform_only_dummies_);
8273           t = current_function_decl;
8274           break;
8275
8276         case FFEINFO_whereGLOBAL:
8277           assert (!ffecom_transform_only_dummies_);
8278
8279           if (((g = ffesymbol_global (s)) != NULL)
8280               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8281                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8282               && (ffeglobal_hook (g) != NULL_TREE)
8283               && ffe_is_globals ())
8284             {
8285               t = ffeglobal_hook (g);
8286               break;
8287             }
8288
8289           t = build_decl (FUNCTION_DECL,
8290                           ffecom_get_external_identifier_ (s),
8291                           ffecom_tree_subr_type);
8292           DECL_EXTERNAL (t) = 1;
8293           TREE_PUBLIC (t) = 1;
8294
8295           t = start_decl (t, FALSE);
8296           finish_decl (t, NULL_TREE, FALSE);
8297
8298           if ((g != NULL)
8299               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8300                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8301             ffeglobal_set_hook (g, t);
8302
8303           ffecom_save_tree_forever (t);
8304
8305           break;
8306
8307         case FFEINFO_whereDUMMY:
8308           assert (ffecom_transform_only_dummies_);
8309
8310           t = build_decl (PARM_DECL,
8311                           ffecom_get_identifier_ (ffesymbol_text (s)),
8312                           ffecom_tree_ptr_to_subr_type);
8313 #if BUILT_FOR_270
8314           DECL_ARTIFICIAL (t) = 1;
8315 #endif
8316           addr = TRUE;
8317           break;
8318
8319         case FFEINFO_whereINTRINSIC:
8320           assert (!ffecom_transform_only_dummies_);
8321           break;                /* Let actual references generate their
8322                                    decls. */
8323
8324         default:
8325           assert ("SUBROUTINE where unheard of" == NULL);
8326           /* Fall through. */
8327         case FFEINFO_whereANY:
8328           t = error_mark_node;
8329           break;
8330         }
8331       break;
8332
8333     case FFEINFO_kindPROGRAM:
8334       switch (ffeinfo_where (ffesymbol_info (s)))
8335         {
8336         case FFEINFO_whereLOCAL:        /* Me. */
8337           assert (!ffecom_transform_only_dummies_);
8338           t = current_function_decl;
8339           break;
8340
8341         case FFEINFO_whereCOMMON:
8342         case FFEINFO_whereDUMMY:
8343         case FFEINFO_whereGLOBAL:
8344         case FFEINFO_whereRESULT:
8345         case FFEINFO_whereFLEETING:
8346         case FFEINFO_whereFLEETING_CADDR:
8347         case FFEINFO_whereFLEETING_IADDR:
8348         case FFEINFO_whereIMMEDIATE:
8349         case FFEINFO_whereINTRINSIC:
8350         case FFEINFO_whereCONSTANT:
8351         case FFEINFO_whereCONSTANT_SUBOBJECT:
8352         default:
8353           assert ("PROGRAM where unheard of" == NULL);
8354           /* Fall through. */
8355         case FFEINFO_whereANY:
8356           t = error_mark_node;
8357           break;
8358         }
8359       break;
8360
8361     case FFEINFO_kindBLOCKDATA:
8362       switch (ffeinfo_where (ffesymbol_info (s)))
8363         {
8364         case FFEINFO_whereLOCAL:        /* Me. */
8365           assert (!ffecom_transform_only_dummies_);
8366           t = current_function_decl;
8367           break;
8368
8369         case FFEINFO_whereGLOBAL:
8370           assert (!ffecom_transform_only_dummies_);
8371
8372           t = build_decl (FUNCTION_DECL,
8373                           ffecom_get_external_identifier_ (s),
8374                           ffecom_tree_blockdata_type);
8375           DECL_EXTERNAL (t) = 1;
8376           TREE_PUBLIC (t) = 1;
8377
8378           t = start_decl (t, FALSE);
8379           finish_decl (t, NULL_TREE, FALSE);
8380
8381           ffecom_save_tree_forever (t);
8382
8383           break;
8384
8385         case FFEINFO_whereCOMMON:
8386         case FFEINFO_whereDUMMY:
8387         case FFEINFO_whereRESULT:
8388         case FFEINFO_whereFLEETING:
8389         case FFEINFO_whereFLEETING_CADDR:
8390         case FFEINFO_whereFLEETING_IADDR:
8391         case FFEINFO_whereIMMEDIATE:
8392         case FFEINFO_whereINTRINSIC:
8393         case FFEINFO_whereCONSTANT:
8394         case FFEINFO_whereCONSTANT_SUBOBJECT:
8395         default:
8396           assert ("BLOCKDATA where unheard of" == NULL);
8397           /* Fall through. */
8398         case FFEINFO_whereANY:
8399           t = error_mark_node;
8400           break;
8401         }
8402       break;
8403
8404     case FFEINFO_kindCOMMON:
8405       switch (ffeinfo_where (ffesymbol_info (s)))
8406         {
8407         case FFEINFO_whereLOCAL:
8408           assert (!ffecom_transform_only_dummies_);
8409           ffecom_transform_common_ (s);
8410           break;
8411
8412         case FFEINFO_whereNONE:
8413         case FFEINFO_whereCOMMON:
8414         case FFEINFO_whereDUMMY:
8415         case FFEINFO_whereGLOBAL:
8416         case FFEINFO_whereRESULT:
8417         case FFEINFO_whereFLEETING:
8418         case FFEINFO_whereFLEETING_CADDR:
8419         case FFEINFO_whereFLEETING_IADDR:
8420         case FFEINFO_whereIMMEDIATE:
8421         case FFEINFO_whereINTRINSIC:
8422         case FFEINFO_whereCONSTANT:
8423         case FFEINFO_whereCONSTANT_SUBOBJECT:
8424         default:
8425           assert ("COMMON where unheard of" == NULL);
8426           /* Fall through. */
8427         case FFEINFO_whereANY:
8428           t = error_mark_node;
8429           break;
8430         }
8431       break;
8432
8433     case FFEINFO_kindCONSTRUCT:
8434       switch (ffeinfo_where (ffesymbol_info (s)))
8435         {
8436         case FFEINFO_whereLOCAL:
8437           assert (!ffecom_transform_only_dummies_);
8438           break;
8439
8440         case FFEINFO_whereNONE:
8441         case FFEINFO_whereCOMMON:
8442         case FFEINFO_whereDUMMY:
8443         case FFEINFO_whereGLOBAL:
8444         case FFEINFO_whereRESULT:
8445         case FFEINFO_whereFLEETING:
8446         case FFEINFO_whereFLEETING_CADDR:
8447         case FFEINFO_whereFLEETING_IADDR:
8448         case FFEINFO_whereIMMEDIATE:
8449         case FFEINFO_whereINTRINSIC:
8450         case FFEINFO_whereCONSTANT:
8451         case FFEINFO_whereCONSTANT_SUBOBJECT:
8452         default:
8453           assert ("CONSTRUCT where unheard of" == NULL);
8454           /* Fall through. */
8455         case FFEINFO_whereANY:
8456           t = error_mark_node;
8457           break;
8458         }
8459       break;
8460
8461     case FFEINFO_kindNAMELIST:
8462       switch (ffeinfo_where (ffesymbol_info (s)))
8463         {
8464         case FFEINFO_whereLOCAL:
8465           assert (!ffecom_transform_only_dummies_);
8466           t = ffecom_transform_namelist_ (s);
8467           break;
8468
8469         case FFEINFO_whereNONE:
8470         case FFEINFO_whereCOMMON:
8471         case FFEINFO_whereDUMMY:
8472         case FFEINFO_whereGLOBAL:
8473         case FFEINFO_whereRESULT:
8474         case FFEINFO_whereFLEETING:
8475         case FFEINFO_whereFLEETING_CADDR:
8476         case FFEINFO_whereFLEETING_IADDR:
8477         case FFEINFO_whereIMMEDIATE:
8478         case FFEINFO_whereINTRINSIC:
8479         case FFEINFO_whereCONSTANT:
8480         case FFEINFO_whereCONSTANT_SUBOBJECT:
8481         default:
8482           assert ("NAMELIST where unheard of" == NULL);
8483           /* Fall through. */
8484         case FFEINFO_whereANY:
8485           t = error_mark_node;
8486           break;
8487         }
8488       break;
8489
8490     default:
8491       assert ("kind unheard of" == NULL);
8492       /* Fall through. */
8493     case FFEINFO_kindANY:
8494       t = error_mark_node;
8495       break;
8496     }
8497
8498   ffesymbol_hook (s).decl_tree = t;
8499   ffesymbol_hook (s).length_tree = tlen;
8500   ffesymbol_hook (s).addr = addr;
8501
8502   lineno = old_lineno;
8503   input_filename = old_input_filename;
8504
8505   return s;
8506 }
8507
8508 #endif
8509 /* Transform into ASSIGNable symbol.
8510
8511    Symbol has already been transformed, but for whatever reason, the
8512    resulting decl_tree has been deemed not usable for an ASSIGN target.
8513    (E.g. it isn't wide enough to hold a pointer.)  So, here we invent
8514    another local symbol of type void * and stuff that in the assign_tree
8515    argument.  The F77/F90 standards allow this implementation.  */
8516
8517 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8518 static ffesymbol
8519 ffecom_sym_transform_assign_ (ffesymbol s)
8520 {
8521   tree t;                       /* Transformed thingy. */
8522   int old_lineno = lineno;
8523   const char *old_input_filename = input_filename;
8524
8525   if (ffesymbol_sfdummyparent (s) == NULL)
8526     {
8527       input_filename = ffesymbol_where_filename (s);
8528       lineno = ffesymbol_where_filelinenum (s);
8529     }
8530   else
8531     {
8532       ffesymbol sf = ffesymbol_sfdummyparent (s);
8533
8534       input_filename = ffesymbol_where_filename (sf);
8535       lineno = ffesymbol_where_filelinenum (sf);
8536     }
8537
8538   assert (!ffecom_transform_only_dummies_);
8539
8540   t = build_decl (VAR_DECL,
8541                   ffecom_get_invented_identifier ("__g77_ASSIGN_%s",
8542                                                    ffesymbol_text (s)),
8543                   TREE_TYPE (null_pointer_node));
8544
8545   switch (ffesymbol_where (s))
8546     {
8547     case FFEINFO_whereLOCAL:
8548       /* Unlike for regular vars, SAVE status is easy to determine for
8549          ASSIGNed vars, since there's no initialization, there's no
8550          effective storage association (so "SAVE J" does not apply to
8551          K even given "EQUIVALENCE (J,K)"), there's no size issue
8552          to worry about, etc.  */
8553       if ((ffesymbol_is_save (s) || ffe_is_saveall ())
8554           && (ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8555           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA))
8556         TREE_STATIC (t) = 1;    /* SAVEd in proc, make static. */
8557       else
8558         TREE_STATIC (t) = 0;    /* No need to make static. */
8559       break;
8560
8561     case FFEINFO_whereCOMMON:
8562       TREE_STATIC (t) = 1;      /* Assume COMMONs always SAVEd. */
8563       break;
8564
8565     case FFEINFO_whereDUMMY:
8566       /* Note that twinning a DUMMY means the caller won't see
8567          the ASSIGNed value.  But both F77 and F90 allow implementations
8568          to do this, i.e. disallow Fortran code that would try and
8569          take advantage of actually putting a label into a variable
8570          via a dummy argument (or any other storage association, for
8571          that matter).  */
8572       TREE_STATIC (t) = 0;
8573       break;
8574
8575     default:
8576       TREE_STATIC (t) = 0;
8577       break;
8578     }
8579
8580   t = start_decl (t, FALSE);
8581   finish_decl (t, NULL_TREE, FALSE);
8582
8583   ffesymbol_hook (s).assign_tree = t;
8584
8585   lineno = old_lineno;
8586   input_filename = old_input_filename;
8587
8588   return s;
8589 }
8590
8591 #endif
8592 /* Implement COMMON area in back end.
8593
8594    Because COMMON-based variables can be referenced in the dimension
8595    expressions of dummy (adjustable) arrays, and because dummies
8596    (in the gcc back end) need to be put in the outer binding level
8597    of a function (which has two binding levels, the outer holding
8598    the dummies and the inner holding the other vars), special care
8599    must be taken to handle COMMON areas.
8600
8601    The current strategy is basically to always tell the back end about
8602    the COMMON area as a top-level external reference to just a block
8603    of storage of the master type of that area (e.g. integer, real,
8604    character, whatever -- not a structure).  As a distinct action,
8605    if initial values are provided, tell the back end about the area
8606    as a top-level non-external (initialized) area and remember not to
8607    allow further initialization or expansion of the area.  Meanwhile,
8608    if no initialization happens at all, tell the back end about
8609    the largest size we've seen declared so the space does get reserved.
8610    (This function doesn't handle all that stuff, but it does some
8611    of the important things.)
8612
8613    Meanwhile, for COMMON variables themselves, just keep creating
8614    references like *((float *) (&common_area + offset)) each time
8615    we reference the variable.  In other words, don't make a VAR_DECL
8616    or any kind of component reference (like we used to do before 0.4),
8617    though we might do that as well just for debugging purposes (and
8618    stuff the rtl with the appropriate offset expression).  */
8619
8620 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8621 static void
8622 ffecom_transform_common_ (ffesymbol s)
8623 {
8624   ffestorag st = ffesymbol_storage (s);
8625   ffeglobal g = ffesymbol_global (s);
8626   tree cbt;
8627   tree cbtype;
8628   tree init;
8629   tree high;
8630   bool is_init = ffestorag_is_init (st);
8631
8632   assert (st != NULL);
8633
8634   if ((g == NULL)
8635       || (ffeglobal_type (g) != FFEGLOBAL_typeCOMMON))
8636     return;
8637
8638   /* First update the size of the area in global terms.  */
8639
8640   ffeglobal_size_common (s, ffestorag_size (st));
8641
8642   if (!ffeglobal_common_init (g))
8643     is_init = FALSE;    /* No explicit init, don't let erroneous joins init. */
8644
8645   cbt = ffeglobal_hook (g);
8646
8647   /* If we already have declared this common block for a previous program
8648      unit, and either we already initialized it or we don't have new
8649      initialization for it, just return what we have without changing it.  */
8650
8651   if ((cbt != NULL_TREE)
8652       && (!is_init
8653           || !DECL_EXTERNAL (cbt)))
8654     {
8655       if (st->hook == NULL) ffestorag_set_hook (st, cbt);
8656       return;
8657     }
8658
8659   /* Process inits.  */
8660
8661   if (is_init)
8662     {
8663       if (ffestorag_init (st) != NULL)
8664         {
8665           ffebld sexp;
8666
8667           /* Set the padding for the expression, so ffecom_expr
8668              knows to insert that many zeros.  */
8669           switch (ffebld_op (sexp = ffestorag_init (st)))
8670             {
8671             case FFEBLD_opCONTER:
8672               ffebld_conter_set_pad (sexp, ffestorag_modulo (st));
8673               break;
8674
8675             case FFEBLD_opARRTER:
8676               ffebld_arrter_set_pad (sexp, ffestorag_modulo (st));
8677               break;
8678
8679             case FFEBLD_opACCTER:
8680               ffebld_accter_set_pad (sexp, ffestorag_modulo (st));
8681               break;
8682
8683             default:
8684               assert ("bad op for cmn init (pad)" == NULL);
8685               break;
8686             }
8687
8688           init = ffecom_expr (sexp);
8689           if (init == error_mark_node)
8690             {                   /* Hopefully the back end complained! */
8691               init = NULL_TREE;
8692               if (cbt != NULL_TREE)
8693                 return;
8694             }
8695         }
8696       else
8697         init = error_mark_node;
8698     }
8699   else
8700     init = NULL_TREE;
8701
8702   /* cbtype must be permanently allocated!  */
8703
8704   /* Allocate the MAX of the areas so far, seen filewide.  */
8705   high = build_int_2 ((ffeglobal_common_size (g)
8706                        + ffeglobal_common_pad (g)) - 1, 0);
8707   TREE_TYPE (high) = ffecom_integer_type_node;
8708
8709   if (init)
8710     cbtype = build_array_type (char_type_node,
8711                                build_range_type (integer_type_node,
8712                                                  integer_zero_node,
8713                                                  high));
8714   else
8715     cbtype = build_array_type (char_type_node, NULL_TREE);
8716
8717   if (cbt == NULL_TREE)
8718     {
8719       cbt
8720         = build_decl (VAR_DECL,
8721                       ffecom_get_external_identifier_ (s),
8722                       cbtype);
8723       TREE_STATIC (cbt) = 1;
8724       TREE_PUBLIC (cbt) = 1;
8725     }
8726   else
8727     {
8728       assert (is_init);
8729       TREE_TYPE (cbt) = cbtype;
8730     }
8731   DECL_EXTERNAL (cbt) = init ? 0 : 1;
8732   DECL_INITIAL (cbt) = init ? error_mark_node : NULL_TREE;
8733
8734   cbt = start_decl (cbt, TRUE);
8735   if (ffeglobal_hook (g) != NULL)
8736     assert (cbt == ffeglobal_hook (g));
8737
8738   assert (!init || !DECL_EXTERNAL (cbt));
8739
8740   /* Make sure that any type can live in COMMON and be referenced
8741      without getting a bus error.  We could pick the most restrictive
8742      alignment of all entities actually placed in the COMMON, but
8743      this seems easy enough.  */
8744
8745   DECL_ALIGN (cbt) = BIGGEST_ALIGNMENT;
8746   DECL_USER_ALIGN (cbt) = 0;
8747
8748   if (is_init && (ffestorag_init (st) == NULL))
8749     init = ffecom_init_zero_ (cbt);
8750
8751   finish_decl (cbt, init, TRUE);
8752
8753   if (is_init)
8754     ffestorag_set_init (st, ffebld_new_any ());
8755
8756   if (init)
8757     {
8758       assert (DECL_SIZE_UNIT (cbt) != NULL_TREE);
8759       assert (TREE_CODE (DECL_SIZE_UNIT (cbt)) == INTEGER_CST);
8760       assert (0 == compare_tree_int (DECL_SIZE_UNIT (cbt),
8761                                      (ffeglobal_common_size (g)
8762                                       + ffeglobal_common_pad (g))));
8763     }
8764
8765   ffeglobal_set_hook (g, cbt);
8766
8767   ffestorag_set_hook (st, cbt);
8768
8769   ffecom_save_tree_forever (cbt);
8770 }
8771
8772 #endif
8773 /* Make master area for local EQUIVALENCE.  */
8774
8775 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8776 static void
8777 ffecom_transform_equiv_ (ffestorag eqst)
8778 {
8779   tree eqt;
8780   tree eqtype;
8781   tree init;
8782   tree high;
8783   bool is_init = ffestorag_is_init (eqst);
8784
8785   assert (eqst != NULL);
8786
8787   eqt = ffestorag_hook (eqst);
8788
8789   if (eqt != NULL_TREE)
8790     return;
8791
8792   /* Process inits.  */
8793
8794   if (is_init)
8795     {
8796       if (ffestorag_init (eqst) != NULL)
8797         {
8798           ffebld sexp;
8799
8800           /* Set the padding for the expression, so ffecom_expr
8801              knows to insert that many zeros.  */
8802           switch (ffebld_op (sexp = ffestorag_init (eqst)))
8803             {
8804             case FFEBLD_opCONTER:
8805               ffebld_conter_set_pad (sexp, ffestorag_modulo (eqst));
8806               break;
8807
8808             case FFEBLD_opARRTER:
8809               ffebld_arrter_set_pad (sexp, ffestorag_modulo (eqst));
8810               break;
8811
8812             case FFEBLD_opACCTER:
8813               ffebld_accter_set_pad (sexp, ffestorag_modulo (eqst));
8814               break;
8815
8816             default:
8817               assert ("bad op for eqv init (pad)" == NULL);
8818               break;
8819             }
8820
8821           init = ffecom_expr (sexp);
8822           if (init == error_mark_node)
8823             init = NULL_TREE;   /* Hopefully the back end complained! */
8824         }
8825       else
8826         init = error_mark_node;
8827     }
8828   else if (ffe_is_init_local_zero ())
8829     init = error_mark_node;
8830   else
8831     init = NULL_TREE;
8832
8833   ffecom_member_namelisted_ = FALSE;
8834   ffestorag_drive (ffestorag_list_equivs (eqst),
8835                    &ffecom_member_phase1_,
8836                    eqst);
8837
8838   high = build_int_2 ((ffestorag_size (eqst)
8839                        + ffestorag_modulo (eqst)) - 1, 0);
8840   TREE_TYPE (high) = ffecom_integer_type_node;
8841
8842   eqtype = build_array_type (char_type_node,
8843                              build_range_type (ffecom_integer_type_node,
8844                                                ffecom_integer_zero_node,
8845                                                high));
8846
8847   eqt = build_decl (VAR_DECL,
8848                     ffecom_get_invented_identifier ("__g77_equiv_%s",
8849                                                     ffesymbol_text
8850                                                     (ffestorag_symbol (eqst))),
8851                     eqtype);
8852   DECL_EXTERNAL (eqt) = 0;
8853   if (is_init
8854       || ffecom_member_namelisted_
8855 #ifdef FFECOM_sizeMAXSTACKITEM
8856       || (ffestorag_size (eqst) > FFECOM_sizeMAXSTACKITEM)
8857 #endif
8858       || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8859           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
8860           && (ffestorag_is_save (eqst) || ffe_is_saveall ())))
8861     TREE_STATIC (eqt) = 1;
8862   else
8863     TREE_STATIC (eqt) = 0;
8864   TREE_PUBLIC (eqt) = 0;
8865   TREE_ADDRESSABLE (eqt) = 1;  /* Ensure non-register allocation */
8866   DECL_CONTEXT (eqt) = current_function_decl;
8867   if (init)
8868     DECL_INITIAL (eqt) = error_mark_node;
8869   else
8870     DECL_INITIAL (eqt) = NULL_TREE;
8871
8872   eqt = start_decl (eqt, FALSE);
8873
8874   /* Make sure that any type can live in EQUIVALENCE and be referenced
8875      without getting a bus error.  We could pick the most restrictive
8876      alignment of all entities actually placed in the EQUIVALENCE, but
8877      this seems easy enough.  */
8878
8879   DECL_ALIGN (eqt) = BIGGEST_ALIGNMENT;
8880   DECL_USER_ALIGN (eqt) = 0;
8881
8882   if ((!is_init && ffe_is_init_local_zero ())
8883       || (is_init && (ffestorag_init (eqst) == NULL)))
8884     init = ffecom_init_zero_ (eqt);
8885
8886   finish_decl (eqt, init, FALSE);
8887
8888   if (is_init)
8889     ffestorag_set_init (eqst, ffebld_new_any ());
8890
8891   {
8892     assert (TREE_CODE (DECL_SIZE_UNIT (eqt)) == INTEGER_CST);
8893     assert (0 == compare_tree_int (DECL_SIZE_UNIT (eqt),
8894                                    (ffestorag_size (eqst)
8895                                     + ffestorag_modulo (eqst))));
8896   }
8897
8898   ffestorag_set_hook (eqst, eqt);
8899
8900   ffestorag_drive (ffestorag_list_equivs (eqst),
8901                    &ffecom_member_phase2_,
8902                    eqst);
8903 }
8904
8905 #endif
8906 /* Implement NAMELIST in back end.  See f2c/format.c for more info.  */
8907
8908 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8909 static tree
8910 ffecom_transform_namelist_ (ffesymbol s)
8911 {
8912   tree nmlt;
8913   tree nmltype = ffecom_type_namelist_ ();
8914   tree nmlinits;
8915   tree nameinit;
8916   tree varsinit;
8917   tree nvarsinit;
8918   tree field;
8919   tree high;
8920   int i;
8921   static int mynumber = 0;
8922
8923   nmlt = build_decl (VAR_DECL,
8924                      ffecom_get_invented_identifier ("__g77_namelist_%d",
8925                                                      mynumber++),
8926                      nmltype);
8927   TREE_STATIC (nmlt) = 1;
8928   DECL_INITIAL (nmlt) = error_mark_node;
8929
8930   nmlt = start_decl (nmlt, FALSE);
8931
8932   /* Process inits.  */
8933
8934   i = strlen (ffesymbol_text (s));
8935
8936   high = build_int_2 (i, 0);
8937   TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
8938
8939   nameinit = ffecom_build_f2c_string_ (i + 1,
8940                                        ffesymbol_text (s));
8941   TREE_TYPE (nameinit)
8942     = build_type_variant
8943     (build_array_type
8944      (char_type_node,
8945       build_range_type (ffecom_f2c_ftnlen_type_node,
8946                         ffecom_f2c_ftnlen_one_node,
8947                         high)),
8948      1, 0);
8949   TREE_CONSTANT (nameinit) = 1;
8950   TREE_STATIC (nameinit) = 1;
8951   nameinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (nameinit)),
8952                        nameinit);
8953
8954   varsinit = ffecom_vardesc_array_ (s);
8955   varsinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (varsinit)),
8956                        varsinit);
8957   TREE_CONSTANT (varsinit) = 1;
8958   TREE_STATIC (varsinit) = 1;
8959
8960   {
8961     ffebld b;
8962
8963     for (i = 0, b = ffesymbol_namelist (s); b != NULL; b = ffebld_trail (b))
8964       ++i;
8965   }
8966   nvarsinit = build_int_2 (i, 0);
8967   TREE_TYPE (nvarsinit) = integer_type_node;
8968   TREE_CONSTANT (nvarsinit) = 1;
8969   TREE_STATIC (nvarsinit) = 1;
8970
8971   nmlinits = build_tree_list ((field = TYPE_FIELDS (nmltype)), nameinit);
8972   TREE_CHAIN (nmlinits) = build_tree_list ((field = TREE_CHAIN (field)),
8973                                            varsinit);
8974   TREE_CHAIN (TREE_CHAIN (nmlinits))
8975     = build_tree_list ((field = TREE_CHAIN (field)), nvarsinit);
8976
8977   nmlinits = build (CONSTRUCTOR, nmltype, NULL_TREE, nmlinits);
8978   TREE_CONSTANT (nmlinits) = 1;
8979   TREE_STATIC (nmlinits) = 1;
8980
8981   finish_decl (nmlt, nmlinits, FALSE);
8982
8983   nmlt = ffecom_1 (ADDR_EXPR, build_pointer_type (nmltype), nmlt);
8984
8985   return nmlt;
8986 }
8987
8988 #endif
8989
8990 /* A subroutine of ffecom_tree_canonize_ref_.  The incoming tree is
8991    analyzed on the assumption it is calculating a pointer to be
8992    indirected through.  It must return the proper decl and offset,
8993    taking into account different units of measurements for offsets.  */
8994
8995 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8996 static void
8997 ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
8998                            tree t)
8999 {
9000   switch (TREE_CODE (t))
9001     {
9002     case NOP_EXPR:
9003     case CONVERT_EXPR:
9004     case NON_LVALUE_EXPR:
9005       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
9006       break;
9007
9008     case PLUS_EXPR:
9009       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
9010       if ((*decl == NULL_TREE)
9011           || (*decl == error_mark_node))
9012         break;
9013
9014       if (TREE_CODE (TREE_OPERAND (t, 1)) == INTEGER_CST)
9015         {
9016           /* An offset into COMMON.  */
9017           *offset = fold (build (PLUS_EXPR, TREE_TYPE (*offset),
9018                                  *offset, TREE_OPERAND (t, 1)));
9019           /* Convert offset (presumably in bytes) into canonical units
9020              (presumably bits).  */
9021           *offset = size_binop (MULT_EXPR,
9022                                 convert (bitsizetype, *offset),
9023                                 TYPE_SIZE (TREE_TYPE (TREE_TYPE (t))));
9024           break;
9025         }
9026       /* Not a COMMON reference, so an unrecognized pattern.  */
9027       *decl = error_mark_node;
9028       break;
9029
9030     case PARM_DECL:
9031       *decl = t;
9032       *offset = bitsize_zero_node;
9033       break;
9034
9035     case ADDR_EXPR:
9036       if (TREE_CODE (TREE_OPERAND (t, 0)) == VAR_DECL)
9037         {
9038           /* A reference to COMMON.  */
9039           *decl = TREE_OPERAND (t, 0);
9040           *offset = bitsize_zero_node;
9041           break;
9042         }
9043       /* Fall through.  */
9044     default:
9045       /* Not a COMMON reference, so an unrecognized pattern.  */
9046       *decl = error_mark_node;
9047       break;
9048     }
9049 }
9050 #endif
9051
9052 /* Given a tree that is possibly intended for use as an lvalue, return
9053    information representing a canonical view of that tree as a decl, an
9054    offset into that decl, and a size for the lvalue.
9055
9056    If there's no applicable decl, NULL_TREE is returned for the decl,
9057    and the other fields are left undefined.
9058
9059    If the tree doesn't fit the recognizable forms, an ERROR_MARK node
9060    is returned for the decl, and the other fields are left undefined.
9061
9062    Otherwise, the decl returned currently is either a VAR_DECL or a
9063    PARM_DECL.
9064
9065    The offset returned is always valid, but of course not necessarily
9066    a constant, and not necessarily converted into the appropriate
9067    type, leaving that up to the caller (so as to avoid that overhead
9068    if the decls being looked at are different anyway).
9069
9070    If the size cannot be determined (e.g. an adjustable array),
9071    an ERROR_MARK node is returned for the size.  Otherwise, the
9072    size returned is valid, not necessarily a constant, and not
9073    necessarily converted into the appropriate type as with the
9074    offset.
9075
9076    Note that the offset and size expressions are expressed in the
9077    base storage units (usually bits) rather than in the units of
9078    the type of the decl, because two decls with different types
9079    might overlap but with apparently non-overlapping array offsets,
9080    whereas converting the array offsets to consistant offsets will
9081    reveal the overlap.  */
9082
9083 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9084 static void
9085 ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
9086                            tree *size, tree t)
9087 {
9088   /* The default path is to report a nonexistant decl.  */
9089   *decl = NULL_TREE;
9090
9091   if (t == NULL_TREE)
9092     return;
9093
9094   switch (TREE_CODE (t))
9095     {
9096     case ERROR_MARK:
9097     case IDENTIFIER_NODE:
9098     case INTEGER_CST:
9099     case REAL_CST:
9100     case COMPLEX_CST:
9101     case STRING_CST:
9102     case CONST_DECL:
9103     case PLUS_EXPR:
9104     case MINUS_EXPR:
9105     case MULT_EXPR:
9106     case TRUNC_DIV_EXPR:
9107     case CEIL_DIV_EXPR:
9108     case FLOOR_DIV_EXPR:
9109     case ROUND_DIV_EXPR:
9110     case TRUNC_MOD_EXPR:
9111     case CEIL_MOD_EXPR:
9112     case FLOOR_MOD_EXPR:
9113     case ROUND_MOD_EXPR:
9114     case RDIV_EXPR:
9115     case EXACT_DIV_EXPR:
9116     case FIX_TRUNC_EXPR:
9117     case FIX_CEIL_EXPR:
9118     case FIX_FLOOR_EXPR:
9119     case FIX_ROUND_EXPR:
9120     case FLOAT_EXPR:
9121     case EXPON_EXPR:
9122     case NEGATE_EXPR:
9123     case MIN_EXPR:
9124     case MAX_EXPR:
9125     case ABS_EXPR:
9126     case FFS_EXPR:
9127     case LSHIFT_EXPR:
9128     case RSHIFT_EXPR:
9129     case LROTATE_EXPR:
9130     case RROTATE_EXPR:
9131     case BIT_IOR_EXPR:
9132     case BIT_XOR_EXPR:
9133     case BIT_AND_EXPR:
9134     case BIT_ANDTC_EXPR:
9135     case BIT_NOT_EXPR:
9136     case TRUTH_ANDIF_EXPR:
9137     case TRUTH_ORIF_EXPR:
9138     case TRUTH_AND_EXPR:
9139     case TRUTH_OR_EXPR:
9140     case TRUTH_XOR_EXPR:
9141     case TRUTH_NOT_EXPR:
9142     case LT_EXPR:
9143     case LE_EXPR:
9144     case GT_EXPR:
9145     case GE_EXPR:
9146     case EQ_EXPR:
9147     case NE_EXPR:
9148     case COMPLEX_EXPR:
9149     case CONJ_EXPR:
9150     case REALPART_EXPR:
9151     case IMAGPART_EXPR:
9152     case LABEL_EXPR:
9153     case COMPONENT_REF:
9154     case COMPOUND_EXPR:
9155     case ADDR_EXPR:
9156       return;
9157
9158     case VAR_DECL:
9159     case PARM_DECL:
9160       *decl = t;
9161       *offset = bitsize_zero_node;
9162       *size = TYPE_SIZE (TREE_TYPE (t));
9163       return;
9164
9165     case ARRAY_REF:
9166       {
9167         tree array = TREE_OPERAND (t, 0);
9168         tree element = TREE_OPERAND (t, 1);
9169         tree init_offset;
9170
9171         if ((array == NULL_TREE)
9172             || (element == NULL_TREE))
9173           {
9174             *decl = error_mark_node;
9175             return;
9176           }
9177
9178         ffecom_tree_canonize_ref_ (decl, &init_offset, size,
9179                                    array);
9180         if ((*decl == NULL_TREE)
9181             || (*decl == error_mark_node))
9182           return;
9183
9184         /* Calculate ((element - base) * NBBY) + init_offset.  */
9185         *offset = fold (build (MINUS_EXPR, TREE_TYPE (element),
9186                                element,
9187                                TYPE_MIN_VALUE (TYPE_DOMAIN
9188                                                (TREE_TYPE (array)))));
9189
9190         *offset = size_binop (MULT_EXPR,
9191                               convert (bitsizetype, *offset),
9192                               TYPE_SIZE (TREE_TYPE (TREE_TYPE (array))));
9193
9194         *offset = size_binop (PLUS_EXPR, init_offset, *offset);
9195
9196         *size = TYPE_SIZE (TREE_TYPE (t));
9197         return;
9198       }
9199
9200     case INDIRECT_REF:
9201
9202       /* Most of this code is to handle references to COMMON.  And so
9203          far that is useful only for calling library functions, since
9204          external (user) functions might reference common areas.  But
9205          even calling an external function, it's worthwhile to decode
9206          COMMON references because if not storing into COMMON, we don't
9207          want COMMON-based arguments to gratuitously force use of a
9208          temporary.  */
9209
9210       *size = TYPE_SIZE (TREE_TYPE (t));
9211
9212       ffecom_tree_canonize_ptr_ (decl, offset,
9213                                  TREE_OPERAND (t, 0));
9214
9215       return;
9216
9217     case CONVERT_EXPR:
9218     case NOP_EXPR:
9219     case MODIFY_EXPR:
9220     case NON_LVALUE_EXPR:
9221     case RESULT_DECL:
9222     case FIELD_DECL:
9223     case COND_EXPR:             /* More cases than we can handle. */
9224     case SAVE_EXPR:
9225     case REFERENCE_EXPR:
9226     case PREDECREMENT_EXPR:
9227     case PREINCREMENT_EXPR:
9228     case POSTDECREMENT_EXPR:
9229     case POSTINCREMENT_EXPR:
9230     case CALL_EXPR:
9231     default:
9232       *decl = error_mark_node;
9233       return;
9234     }
9235 }
9236 #endif
9237
9238 /* Do divide operation appropriate to type of operands.  */
9239
9240 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9241 static tree
9242 ffecom_tree_divide_ (tree tree_type, tree left, tree right,
9243                      tree dest_tree, ffebld dest, bool *dest_used,
9244                      tree hook)
9245 {
9246   if ((left == error_mark_node)
9247       || (right == error_mark_node))
9248     return error_mark_node;
9249
9250   switch (TREE_CODE (tree_type))
9251     {
9252     case INTEGER_TYPE:
9253       return ffecom_2 (TRUNC_DIV_EXPR, tree_type,
9254                        left,
9255                        right);
9256
9257     case COMPLEX_TYPE:
9258       if (! optimize_size)
9259         return ffecom_2 (RDIV_EXPR, tree_type,
9260                          left,
9261                          right);
9262       {
9263         ffecomGfrt ix;
9264
9265         if (TREE_TYPE (tree_type)
9266             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9267           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9268         else
9269           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9270
9271         left = ffecom_1 (ADDR_EXPR,
9272                          build_pointer_type (TREE_TYPE (left)),
9273                          left);
9274         left = build_tree_list (NULL_TREE, left);
9275         right = ffecom_1 (ADDR_EXPR,
9276                           build_pointer_type (TREE_TYPE (right)),
9277                           right);
9278         right = build_tree_list (NULL_TREE, right);
9279         TREE_CHAIN (left) = right;
9280
9281         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9282                              ffecom_gfrt_kindtype (ix),
9283                              ffe_is_f2c_library (),
9284                              tree_type,
9285                              left,
9286                              dest_tree, dest, dest_used,
9287                              NULL_TREE, TRUE, hook);
9288       }
9289       break;
9290
9291     case RECORD_TYPE:
9292       {
9293         ffecomGfrt ix;
9294
9295         if (TREE_TYPE (TYPE_FIELDS (tree_type))
9296             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9297           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9298         else
9299           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9300
9301         left = ffecom_1 (ADDR_EXPR,
9302                          build_pointer_type (TREE_TYPE (left)),
9303                          left);
9304         left = build_tree_list (NULL_TREE, left);
9305         right = ffecom_1 (ADDR_EXPR,
9306                           build_pointer_type (TREE_TYPE (right)),
9307                           right);
9308         right = build_tree_list (NULL_TREE, right);
9309         TREE_CHAIN (left) = right;
9310
9311         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9312                              ffecom_gfrt_kindtype (ix),
9313                              ffe_is_f2c_library (),
9314                              tree_type,
9315                              left,
9316                              dest_tree, dest, dest_used,
9317                              NULL_TREE, TRUE, hook);
9318       }
9319       break;
9320
9321     default:
9322       return ffecom_2 (RDIV_EXPR, tree_type,
9323                        left,
9324                        right);
9325     }
9326 }
9327
9328 #endif
9329 /* Build type info for non-dummy variable.  */
9330
9331 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9332 static tree
9333 ffecom_type_localvar_ (ffesymbol s, ffeinfoBasictype bt,
9334                        ffeinfoKindtype kt)
9335 {
9336   tree type;
9337   ffebld dl;
9338   ffebld dim;
9339   tree lowt;
9340   tree hight;
9341
9342   type = ffecom_tree_type[bt][kt];
9343   if (bt == FFEINFO_basictypeCHARACTER)
9344     {
9345       hight = build_int_2 (ffesymbol_size (s), 0);
9346       TREE_TYPE (hight) = ffecom_f2c_ftnlen_type_node;
9347
9348       type
9349         = build_array_type
9350           (type,
9351            build_range_type (ffecom_f2c_ftnlen_type_node,
9352                              ffecom_f2c_ftnlen_one_node,
9353                              hight));
9354       type = ffecom_check_size_overflow_ (s, type, FALSE);
9355     }
9356
9357   for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
9358     {
9359       if (type == error_mark_node)
9360         break;
9361
9362       dim = ffebld_head (dl);
9363       assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
9364
9365       if (ffebld_left (dim) == NULL)
9366         lowt = integer_one_node;
9367       else
9368         lowt = ffecom_expr (ffebld_left (dim));
9369
9370       if (TREE_CODE (lowt) != INTEGER_CST)
9371         lowt = variable_size (lowt);
9372
9373       assert (ffebld_right (dim) != NULL);
9374       hight = ffecom_expr (ffebld_right (dim));
9375
9376       if (TREE_CODE (hight) != INTEGER_CST)
9377         hight = variable_size (hight);
9378
9379       type = build_array_type (type,
9380                                build_range_type (ffecom_integer_type_node,
9381                                                  lowt, hight));
9382       type = ffecom_check_size_overflow_ (s, type, FALSE);
9383     }
9384
9385   return type;
9386 }
9387
9388 #endif
9389 /* Build Namelist type.  */
9390
9391 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9392 static tree
9393 ffecom_type_namelist_ ()
9394 {
9395   static tree type = NULL_TREE;
9396
9397   if (type == NULL_TREE)
9398     {
9399       static tree namefield, varsfield, nvarsfield;
9400       tree vardesctype;
9401
9402       vardesctype = ffecom_type_vardesc_ ();
9403
9404       type = make_node (RECORD_TYPE);
9405
9406       vardesctype = build_pointer_type (build_pointer_type (vardesctype));
9407
9408       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9409                                      string_type_node);
9410       varsfield = ffecom_decl_field (type, namefield, "vars", vardesctype);
9411       nvarsfield = ffecom_decl_field (type, varsfield, "nvars",
9412                                       integer_type_node);
9413
9414       TYPE_FIELDS (type) = namefield;
9415       layout_type (type);
9416
9417       ggc_add_tree_root (&type, 1);
9418     }
9419
9420   return type;
9421 }
9422
9423 #endif
9424
9425 /* Build Vardesc type.  */
9426
9427 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9428 static tree
9429 ffecom_type_vardesc_ ()
9430 {
9431   static tree type = NULL_TREE;
9432   static tree namefield, addrfield, dimsfield, typefield;
9433
9434   if (type == NULL_TREE)
9435     {
9436       type = make_node (RECORD_TYPE);
9437
9438       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9439                                      string_type_node);
9440       addrfield = ffecom_decl_field (type, namefield, "addr",
9441                                      string_type_node);
9442       dimsfield = ffecom_decl_field (type, addrfield, "dims",
9443                                      ffecom_f2c_ptr_to_ftnlen_type_node);
9444       typefield = ffecom_decl_field (type, dimsfield, "type",
9445                                      integer_type_node);
9446
9447       TYPE_FIELDS (type) = namefield;
9448       layout_type (type);
9449
9450       ggc_add_tree_root (&type, 1);
9451     }
9452
9453   return type;
9454 }
9455
9456 #endif
9457
9458 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9459 static tree
9460 ffecom_vardesc_ (ffebld expr)
9461 {
9462   ffesymbol s;
9463
9464   assert (ffebld_op (expr) == FFEBLD_opSYMTER);
9465   s = ffebld_symter (expr);
9466
9467   if (ffesymbol_hook (s).vardesc_tree == NULL_TREE)
9468     {
9469       int i;
9470       tree vardesctype = ffecom_type_vardesc_ ();
9471       tree var;
9472       tree nameinit;
9473       tree dimsinit;
9474       tree addrinit;
9475       tree typeinit;
9476       tree field;
9477       tree varinits;
9478       static int mynumber = 0;
9479
9480       var = build_decl (VAR_DECL,
9481                         ffecom_get_invented_identifier ("__g77_vardesc_%d",
9482                                                         mynumber++),
9483                         vardesctype);
9484       TREE_STATIC (var) = 1;
9485       DECL_INITIAL (var) = error_mark_node;
9486
9487       var = start_decl (var, FALSE);
9488
9489       /* Process inits.  */
9490
9491       nameinit = ffecom_build_f2c_string_ ((i = strlen (ffesymbol_text (s)))
9492                                            + 1,
9493                                            ffesymbol_text (s));
9494       TREE_TYPE (nameinit)
9495         = build_type_variant
9496         (build_array_type
9497          (char_type_node,
9498           build_range_type (integer_type_node,
9499                             integer_one_node,
9500                             build_int_2 (i, 0))),
9501          1, 0);
9502       TREE_CONSTANT (nameinit) = 1;
9503       TREE_STATIC (nameinit) = 1;
9504       nameinit = ffecom_1 (ADDR_EXPR,
9505                            build_pointer_type (TREE_TYPE (nameinit)),
9506                            nameinit);
9507
9508       addrinit = ffecom_arg_ptr_to_expr (expr, &typeinit);
9509
9510       dimsinit = ffecom_vardesc_dims_ (s);
9511
9512       if (typeinit == NULL_TREE)
9513         {
9514           ffeinfoBasictype bt = ffesymbol_basictype (s);
9515           ffeinfoKindtype kt = ffesymbol_kindtype (s);
9516           int tc = ffecom_f2c_typecode (bt, kt);
9517
9518           assert (tc != -1);
9519           typeinit = build_int_2 (tc, (tc < 0) ? -1 : 0);
9520         }
9521       else
9522         typeinit = ffecom_1 (NEGATE_EXPR, TREE_TYPE (typeinit), typeinit);
9523
9524       varinits = build_tree_list ((field = TYPE_FIELDS (vardesctype)),
9525                                   nameinit);
9526       TREE_CHAIN (varinits) = build_tree_list ((field = TREE_CHAIN (field)),
9527                                                addrinit);
9528       TREE_CHAIN (TREE_CHAIN (varinits))
9529         = build_tree_list ((field = TREE_CHAIN (field)), dimsinit);
9530       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits)))
9531         = build_tree_list ((field = TREE_CHAIN (field)), typeinit);
9532
9533       varinits = build (CONSTRUCTOR, vardesctype, NULL_TREE, varinits);
9534       TREE_CONSTANT (varinits) = 1;
9535       TREE_STATIC (varinits) = 1;
9536
9537       finish_decl (var, varinits, FALSE);
9538
9539       var = ffecom_1 (ADDR_EXPR, build_pointer_type (vardesctype), var);
9540
9541       ffesymbol_hook (s).vardesc_tree = var;
9542     }
9543
9544   return ffesymbol_hook (s).vardesc_tree;
9545 }
9546
9547 #endif
9548 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9549 static tree
9550 ffecom_vardesc_array_ (ffesymbol s)
9551 {
9552   ffebld b;
9553   tree list;
9554   tree item = NULL_TREE;
9555   tree var;
9556   int i;
9557   static int mynumber = 0;
9558
9559   for (i = 0, list = NULL_TREE, b = ffesymbol_namelist (s);
9560        b != NULL;
9561        b = ffebld_trail (b), ++i)
9562     {
9563       tree t;
9564
9565       t = ffecom_vardesc_ (ffebld_head (b));
9566
9567       if (list == NULL_TREE)
9568         list = item = build_tree_list (NULL_TREE, t);
9569       else
9570         {
9571           TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9572           item = TREE_CHAIN (item);
9573         }
9574     }
9575
9576   item = build_array_type (build_pointer_type (ffecom_type_vardesc_ ()),
9577                            build_range_type (integer_type_node,
9578                                              integer_one_node,
9579                                              build_int_2 (i, 0)));
9580   list = build (CONSTRUCTOR, item, NULL_TREE, list);
9581   TREE_CONSTANT (list) = 1;
9582   TREE_STATIC (list) = 1;
9583
9584   var = ffecom_get_invented_identifier ("__g77_vardesc_array_%d", mynumber++);
9585   var = build_decl (VAR_DECL, var, item);
9586   TREE_STATIC (var) = 1;
9587   DECL_INITIAL (var) = error_mark_node;
9588   var = start_decl (var, FALSE);
9589   finish_decl (var, list, FALSE);
9590
9591   return var;
9592 }
9593
9594 #endif
9595 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9596 static tree
9597 ffecom_vardesc_dims_ (ffesymbol s)
9598 {
9599   if (ffesymbol_dims (s) == NULL)
9600     return convert (ffecom_f2c_ptr_to_ftnlen_type_node,
9601                     integer_zero_node);
9602
9603   {
9604     ffebld b;
9605     ffebld e;
9606     tree list;
9607     tree backlist;
9608     tree item = NULL_TREE;
9609     tree var;
9610     tree numdim;
9611     tree numelem;
9612     tree baseoff = NULL_TREE;
9613     static int mynumber = 0;
9614
9615     numdim = build_int_2 ((int) ffesymbol_rank (s), 0);
9616     TREE_TYPE (numdim) = ffecom_f2c_ftnlen_type_node;
9617
9618     numelem = ffecom_expr (ffesymbol_arraysize (s));
9619     TREE_TYPE (numelem) = ffecom_f2c_ftnlen_type_node;
9620
9621     list = NULL_TREE;
9622     backlist = NULL_TREE;
9623     for (b = ffesymbol_dims (s), e = ffesymbol_extents (s);
9624          b != NULL;
9625          b = ffebld_trail (b), e = ffebld_trail (e))
9626       {
9627         tree t;
9628         tree low;
9629         tree back;
9630
9631         if (ffebld_trail (b) == NULL)
9632           t = NULL_TREE;
9633         else
9634           {
9635             t = convert (ffecom_f2c_ftnlen_type_node,
9636                          ffecom_expr (ffebld_head (e)));
9637
9638             if (list == NULL_TREE)
9639               list = item = build_tree_list (NULL_TREE, t);
9640             else
9641               {
9642                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9643                 item = TREE_CHAIN (item);
9644               }
9645           }
9646
9647         if (ffebld_left (ffebld_head (b)) == NULL)
9648           low = ffecom_integer_one_node;
9649         else
9650           low = ffecom_expr (ffebld_left (ffebld_head (b)));
9651         low = convert (ffecom_f2c_ftnlen_type_node, low);
9652
9653         back = build_tree_list (low, t);
9654         TREE_CHAIN (back) = backlist;
9655         backlist = back;
9656       }
9657
9658     for (item = backlist; item != NULL_TREE; item = TREE_CHAIN (item))
9659       {
9660         if (TREE_VALUE (item) == NULL_TREE)
9661           baseoff = TREE_PURPOSE (item);
9662         else
9663           baseoff = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
9664                               TREE_PURPOSE (item),
9665                               ffecom_2 (MULT_EXPR,
9666                                         ffecom_f2c_ftnlen_type_node,
9667                                         TREE_VALUE (item),
9668                                         baseoff));
9669       }
9670
9671     /* backlist now dead, along with all TREE_PURPOSEs on it.  */
9672
9673     baseoff = build_tree_list (NULL_TREE, baseoff);
9674     TREE_CHAIN (baseoff) = list;
9675
9676     numelem = build_tree_list (NULL_TREE, numelem);
9677     TREE_CHAIN (numelem) = baseoff;
9678
9679     numdim = build_tree_list (NULL_TREE, numdim);
9680     TREE_CHAIN (numdim) = numelem;
9681
9682     item = build_array_type (ffecom_f2c_ftnlen_type_node,
9683                              build_range_type (integer_type_node,
9684                                                integer_zero_node,
9685                                                build_int_2
9686                                                ((int) ffesymbol_rank (s)
9687                                                 + 2, 0)));
9688     list = build (CONSTRUCTOR, item, NULL_TREE, numdim);
9689     TREE_CONSTANT (list) = 1;
9690     TREE_STATIC (list) = 1;
9691
9692     var = ffecom_get_invented_identifier ("__g77_dims_%d", mynumber++);
9693     var = build_decl (VAR_DECL, var, item);
9694     TREE_STATIC (var) = 1;
9695     DECL_INITIAL (var) = error_mark_node;
9696     var = start_decl (var, FALSE);
9697     finish_decl (var, list, FALSE);
9698
9699     var = ffecom_1 (ADDR_EXPR, build_pointer_type (item), var);
9700
9701     return var;
9702   }
9703 }
9704
9705 #endif
9706 /* Essentially does a "fold (build1 (code, type, node))" while checking
9707    for certain housekeeping things.
9708
9709    NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
9710    ffecom_1_fn instead.  */
9711
9712 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9713 tree
9714 ffecom_1 (enum tree_code code, tree type, tree node)
9715 {
9716   tree item;
9717
9718   if ((node == error_mark_node)
9719       || (type == error_mark_node))
9720     return error_mark_node;
9721
9722   if (code == ADDR_EXPR)
9723     {
9724       if (!mark_addressable (node))
9725         assert ("can't mark_addressable this node!" == NULL);
9726     }
9727
9728   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9729     {
9730       tree realtype;
9731
9732     case REALPART_EXPR:
9733       item = build (COMPONENT_REF, type, node, TYPE_FIELDS (TREE_TYPE (node)));
9734       break;
9735
9736     case IMAGPART_EXPR:
9737       item = build (COMPONENT_REF, type, node, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node))));
9738       break;
9739
9740
9741     case NEGATE_EXPR:
9742       if (TREE_CODE (type) != RECORD_TYPE)
9743         {
9744           item = build1 (code, type, node);
9745           break;
9746         }
9747       node = ffecom_stabilize_aggregate_ (node);
9748       realtype = TREE_TYPE (TYPE_FIELDS (type));
9749       item =
9750         ffecom_2 (COMPLEX_EXPR, type,
9751                   ffecom_1 (NEGATE_EXPR, realtype,
9752                             ffecom_1 (REALPART_EXPR, realtype,
9753                                       node)),
9754                   ffecom_1 (NEGATE_EXPR, realtype,
9755                             ffecom_1 (IMAGPART_EXPR, realtype,
9756                                       node)));
9757       break;
9758
9759     default:
9760       item = build1 (code, type, node);
9761       break;
9762     }
9763
9764   if (TREE_SIDE_EFFECTS (node))
9765     TREE_SIDE_EFFECTS (item) = 1;
9766   if ((code == ADDR_EXPR) && staticp (node))
9767     TREE_CONSTANT (item) = 1;
9768   return fold (item);
9769 }
9770 #endif
9771
9772 /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
9773    handles TREE_CODE (node) == FUNCTION_DECL.  In particular,
9774    does not set TREE_ADDRESSABLE (because calling an inline
9775    function does not mean the function needs to be separately
9776    compiled).  */
9777
9778 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9779 tree
9780 ffecom_1_fn (tree node)
9781 {
9782   tree item;
9783   tree type;
9784
9785   if (node == error_mark_node)
9786     return error_mark_node;
9787
9788   type = build_type_variant (TREE_TYPE (node),
9789                              TREE_READONLY (node),
9790                              TREE_THIS_VOLATILE (node));
9791   item = build1 (ADDR_EXPR,
9792                  build_pointer_type (type), node);
9793   if (TREE_SIDE_EFFECTS (node))
9794     TREE_SIDE_EFFECTS (item) = 1;
9795   if (staticp (node))
9796     TREE_CONSTANT (item) = 1;
9797   return fold (item);
9798 }
9799 #endif
9800
9801 /* Essentially does a "fold (build (code, type, node1, node2))" while
9802    checking for certain housekeeping things.  */
9803
9804 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9805 tree
9806 ffecom_2 (enum tree_code code, tree type, tree node1,
9807           tree node2)
9808 {
9809   tree item;
9810
9811   if ((node1 == error_mark_node)
9812       || (node2 == error_mark_node)
9813       || (type == error_mark_node))
9814     return error_mark_node;
9815
9816   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9817     {
9818       tree a, b, c, d, realtype;
9819
9820     case CONJ_EXPR:
9821       assert ("no CONJ_EXPR support yet" == NULL);
9822       return error_mark_node;
9823
9824     case COMPLEX_EXPR:
9825       item = build_tree_list (TYPE_FIELDS (type), node1);
9826       TREE_CHAIN (item) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), node2);
9827       item = build (CONSTRUCTOR, type, NULL_TREE, item);
9828       break;
9829
9830     case PLUS_EXPR:
9831       if (TREE_CODE (type) != RECORD_TYPE)
9832         {
9833           item = build (code, type, node1, node2);
9834           break;
9835         }
9836       node1 = ffecom_stabilize_aggregate_ (node1);
9837       node2 = ffecom_stabilize_aggregate_ (node2);
9838       realtype = TREE_TYPE (TYPE_FIELDS (type));
9839       item =
9840         ffecom_2 (COMPLEX_EXPR, type,
9841                   ffecom_2 (PLUS_EXPR, realtype,
9842                             ffecom_1 (REALPART_EXPR, realtype,
9843                                       node1),
9844                             ffecom_1 (REALPART_EXPR, realtype,
9845                                       node2)),
9846                   ffecom_2 (PLUS_EXPR, realtype,
9847                             ffecom_1 (IMAGPART_EXPR, realtype,
9848                                       node1),
9849                             ffecom_1 (IMAGPART_EXPR, realtype,
9850                                       node2)));
9851       break;
9852
9853     case MINUS_EXPR:
9854       if (TREE_CODE (type) != RECORD_TYPE)
9855         {
9856           item = build (code, type, node1, node2);
9857           break;
9858         }
9859       node1 = ffecom_stabilize_aggregate_ (node1);
9860       node2 = ffecom_stabilize_aggregate_ (node2);
9861       realtype = TREE_TYPE (TYPE_FIELDS (type));
9862       item =
9863         ffecom_2 (COMPLEX_EXPR, type,
9864                   ffecom_2 (MINUS_EXPR, realtype,
9865                             ffecom_1 (REALPART_EXPR, realtype,
9866                                       node1),
9867                             ffecom_1 (REALPART_EXPR, realtype,
9868                                       node2)),
9869                   ffecom_2 (MINUS_EXPR, realtype,
9870                             ffecom_1 (IMAGPART_EXPR, realtype,
9871                                       node1),
9872                             ffecom_1 (IMAGPART_EXPR, realtype,
9873                                       node2)));
9874       break;
9875
9876     case MULT_EXPR:
9877       if (TREE_CODE (type) != RECORD_TYPE)
9878         {
9879           item = build (code, type, node1, node2);
9880           break;
9881         }
9882       node1 = ffecom_stabilize_aggregate_ (node1);
9883       node2 = ffecom_stabilize_aggregate_ (node2);
9884       realtype = TREE_TYPE (TYPE_FIELDS (type));
9885       a = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9886                                node1));
9887       b = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9888                                node1));
9889       c = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9890                                node2));
9891       d = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9892                                node2));
9893       item =
9894         ffecom_2 (COMPLEX_EXPR, type,
9895                   ffecom_2 (MINUS_EXPR, realtype,
9896                             ffecom_2 (MULT_EXPR, realtype,
9897                                       a,
9898                                       c),
9899                             ffecom_2 (MULT_EXPR, realtype,
9900                                       b,
9901                                       d)),
9902                   ffecom_2 (PLUS_EXPR, realtype,
9903                             ffecom_2 (MULT_EXPR, realtype,
9904                                       a,
9905                                       d),
9906                             ffecom_2 (MULT_EXPR, realtype,
9907                                       c,
9908                                       b)));
9909       break;
9910
9911     case EQ_EXPR:
9912       if ((TREE_CODE (node1) != RECORD_TYPE)
9913           && (TREE_CODE (node2) != RECORD_TYPE))
9914         {
9915           item = build (code, type, node1, node2);
9916           break;
9917         }
9918       assert (TREE_CODE (node1) == RECORD_TYPE);
9919       assert (TREE_CODE (node2) == RECORD_TYPE);
9920       node1 = ffecom_stabilize_aggregate_ (node1);
9921       node2 = ffecom_stabilize_aggregate_ (node2);
9922       realtype = TREE_TYPE (TYPE_FIELDS (type));
9923       item =
9924         ffecom_2 (TRUTH_ANDIF_EXPR, type,
9925                   ffecom_2 (code, type,
9926                             ffecom_1 (REALPART_EXPR, realtype,
9927                                       node1),
9928                             ffecom_1 (REALPART_EXPR, realtype,
9929                                       node2)),
9930                   ffecom_2 (code, type,
9931                             ffecom_1 (IMAGPART_EXPR, realtype,
9932                                       node1),
9933                             ffecom_1 (IMAGPART_EXPR, realtype,
9934                                       node2)));
9935       break;
9936
9937     case NE_EXPR:
9938       if ((TREE_CODE (node1) != RECORD_TYPE)
9939           && (TREE_CODE (node2) != RECORD_TYPE))
9940         {
9941           item = build (code, type, node1, node2);
9942           break;
9943         }
9944       assert (TREE_CODE (node1) == RECORD_TYPE);
9945       assert (TREE_CODE (node2) == RECORD_TYPE);
9946       node1 = ffecom_stabilize_aggregate_ (node1);
9947       node2 = ffecom_stabilize_aggregate_ (node2);
9948       realtype = TREE_TYPE (TYPE_FIELDS (type));
9949       item =
9950         ffecom_2 (TRUTH_ORIF_EXPR, type,
9951                   ffecom_2 (code, type,
9952                             ffecom_1 (REALPART_EXPR, realtype,
9953                                       node1),
9954                             ffecom_1 (REALPART_EXPR, realtype,
9955                                       node2)),
9956                   ffecom_2 (code, type,
9957                             ffecom_1 (IMAGPART_EXPR, realtype,
9958                                       node1),
9959                             ffecom_1 (IMAGPART_EXPR, realtype,
9960                                       node2)));
9961       break;
9962
9963     default:
9964       item = build (code, type, node1, node2);
9965       break;
9966     }
9967
9968   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2))
9969     TREE_SIDE_EFFECTS (item) = 1;
9970   return fold (item);
9971 }
9972
9973 #endif
9974 /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
9975
9976    ffesymbol s;  // the ENTRY point itself
9977    if (ffecom_2pass_advise_entrypoint(s))
9978        // the ENTRY point has been accepted
9979
9980    Does whatever compiler needs to do when it learns about the entrypoint,
9981    like determine the return type of the master function, count the
9982    number of entrypoints, etc.  Returns FALSE if the return type is
9983    not compatible with the return type(s) of other entrypoint(s).
9984
9985    NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
9986    later (after _finish_progunit) be called with the same entrypoint(s)
9987    as passed to this fn for which TRUE was returned.
9988
9989    03-Jan-92  JCB  2.0
9990       Return FALSE if the return type conflicts with previous entrypoints.  */
9991
9992 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9993 bool
9994 ffecom_2pass_advise_entrypoint (ffesymbol entry)
9995 {
9996   ffebld list;                  /* opITEM. */
9997   ffebld mlist;                 /* opITEM. */
9998   ffebld plist;                 /* opITEM. */
9999   ffebld arg;                   /* ffebld_head(opITEM). */
10000   ffebld item;                  /* opITEM. */
10001   ffesymbol s;                  /* ffebld_symter(arg). */
10002   ffeinfoBasictype bt = ffesymbol_basictype (entry);
10003   ffeinfoKindtype kt = ffesymbol_kindtype (entry);
10004   ffetargetCharacterSize size = ffesymbol_size (entry);
10005   bool ok;
10006
10007   if (ffecom_num_entrypoints_ == 0)
10008     {                           /* First entrypoint, make list of main
10009                                    arglist's dummies. */
10010       assert (ffecom_primary_entry_ != NULL);
10011
10012       ffecom_master_bt_ = ffesymbol_basictype (ffecom_primary_entry_);
10013       ffecom_master_kt_ = ffesymbol_kindtype (ffecom_primary_entry_);
10014       ffecom_master_size_ = ffesymbol_size (ffecom_primary_entry_);
10015
10016       for (plist = NULL, list = ffesymbol_dummyargs (ffecom_primary_entry_);
10017            list != NULL;
10018            list = ffebld_trail (list))
10019         {
10020           arg = ffebld_head (list);
10021           if (ffebld_op (arg) != FFEBLD_opSYMTER)
10022             continue;           /* Alternate return or some such thing. */
10023           item = ffebld_new_item (arg, NULL);
10024           if (plist == NULL)
10025             ffecom_master_arglist_ = item;
10026           else
10027             ffebld_set_trail (plist, item);
10028           plist = item;
10029         }
10030     }
10031
10032   /* If necessary, scan entry arglist for alternate returns.  Do this scan
10033      apparently redundantly (it's done below to UNIONize the arglists) so
10034      that we don't complain about RETURN 1 if an offending ENTRY is the only
10035      one with an alternate return.  */
10036
10037   if (!ffecom_is_altreturning_)
10038     {
10039       for (list = ffesymbol_dummyargs (entry);
10040            list != NULL;
10041            list = ffebld_trail (list))
10042         {
10043           arg = ffebld_head (list);
10044           if (ffebld_op (arg) == FFEBLD_opSTAR)
10045             {
10046               ffecom_is_altreturning_ = TRUE;
10047               break;
10048             }
10049         }
10050     }
10051
10052   /* Now check type compatibility. */
10053
10054   switch (ffecom_master_bt_)
10055     {
10056     case FFEINFO_basictypeNONE:
10057       ok = (bt != FFEINFO_basictypeCHARACTER);
10058       break;
10059
10060     case FFEINFO_basictypeCHARACTER:
10061       ok
10062         = (bt == FFEINFO_basictypeCHARACTER)
10063         && (kt == ffecom_master_kt_)
10064         && (size == ffecom_master_size_);
10065       break;
10066
10067     case FFEINFO_basictypeANY:
10068       return FALSE;             /* Just don't bother. */
10069
10070     default:
10071       if (bt == FFEINFO_basictypeCHARACTER)
10072         {
10073           ok = FALSE;
10074           break;
10075         }
10076       ok = TRUE;
10077       if ((bt != ffecom_master_bt_) || (kt != ffecom_master_kt_))
10078         {
10079           ffecom_master_bt_ = FFEINFO_basictypeNONE;
10080           ffecom_master_kt_ = FFEINFO_kindtypeNONE;
10081         }
10082       break;
10083     }
10084
10085   if (!ok)
10086     {
10087       ffebad_start (FFEBAD_ENTRY_CONFLICTS);
10088       ffest_ffebad_here_current_stmt (0);
10089       ffebad_finish ();
10090       return FALSE;             /* Can't handle entrypoint. */
10091     }
10092
10093   /* Entrypoint type compatible with previous types. */
10094
10095   ++ffecom_num_entrypoints_;
10096
10097   /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
10098
10099   for (list = ffesymbol_dummyargs (entry);
10100        list != NULL;
10101        list = ffebld_trail (list))
10102     {
10103       arg = ffebld_head (list);
10104       if (ffebld_op (arg) != FFEBLD_opSYMTER)
10105         continue;               /* Alternate return or some such thing. */
10106       s = ffebld_symter (arg);
10107       for (plist = NULL, mlist = ffecom_master_arglist_;
10108            mlist != NULL;
10109            plist = mlist, mlist = ffebld_trail (mlist))
10110         {                       /* plist points to previous item for easy
10111                                    appending of arg. */
10112           if (ffebld_symter (ffebld_head (mlist)) == s)
10113             break;              /* Already have this arg in the master list. */
10114         }
10115       if (mlist != NULL)
10116         continue;               /* Already have this arg in the master list. */
10117
10118       /* Append this arg to the master list. */
10119
10120       item = ffebld_new_item (arg, NULL);
10121       if (plist == NULL)
10122         ffecom_master_arglist_ = item;
10123       else
10124         ffebld_set_trail (plist, item);
10125     }
10126
10127   return TRUE;
10128 }
10129
10130 #endif
10131 /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
10132
10133    ffesymbol s;  // the ENTRY point itself
10134    ffecom_2pass_do_entrypoint(s);
10135
10136    Does whatever compiler needs to do to make the entrypoint actually
10137    happen.  Must be called for each entrypoint after
10138    ffecom_finish_progunit is called.  */
10139
10140 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10141 void
10142 ffecom_2pass_do_entrypoint (ffesymbol entry)
10143 {
10144   static int mfn_num = 0;
10145   static int ent_num;
10146
10147   if (mfn_num != ffecom_num_fns_)
10148     {                           /* First entrypoint for this program unit. */
10149       ent_num = 1;
10150       mfn_num = ffecom_num_fns_;
10151       ffecom_do_entry_ (ffecom_primary_entry_, 0);
10152     }
10153   else
10154     ++ent_num;
10155
10156   --ffecom_num_entrypoints_;
10157
10158   ffecom_do_entry_ (entry, ent_num);
10159 }
10160
10161 #endif
10162
10163 /* Essentially does a "fold (build (code, type, node1, node2))" while
10164    checking for certain housekeeping things.  Always sets
10165    TREE_SIDE_EFFECTS.  */
10166
10167 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10168 tree
10169 ffecom_2s (enum tree_code code, tree type, tree node1,
10170            tree node2)
10171 {
10172   tree item;
10173
10174   if ((node1 == error_mark_node)
10175       || (node2 == error_mark_node)
10176       || (type == error_mark_node))
10177     return error_mark_node;
10178
10179   item = build (code, type, node1, node2);
10180   TREE_SIDE_EFFECTS (item) = 1;
10181   return fold (item);
10182 }
10183
10184 #endif
10185 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10186    checking for certain housekeeping things.  */
10187
10188 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10189 tree
10190 ffecom_3 (enum tree_code code, tree type, tree node1,
10191           tree node2, tree node3)
10192 {
10193   tree item;
10194
10195   if ((node1 == error_mark_node)
10196       || (node2 == error_mark_node)
10197       || (node3 == error_mark_node)
10198       || (type == error_mark_node))
10199     return error_mark_node;
10200
10201   item = build (code, type, node1, node2, node3);
10202   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2)
10203       || (node3 != NULL_TREE && TREE_SIDE_EFFECTS (node3)))
10204     TREE_SIDE_EFFECTS (item) = 1;
10205   return fold (item);
10206 }
10207
10208 #endif
10209 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10210    checking for certain housekeeping things.  Always sets
10211    TREE_SIDE_EFFECTS.  */
10212
10213 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10214 tree
10215 ffecom_3s (enum tree_code code, tree type, tree node1,
10216            tree node2, tree node3)
10217 {
10218   tree item;
10219
10220   if ((node1 == error_mark_node)
10221       || (node2 == error_mark_node)
10222       || (node3 == error_mark_node)
10223       || (type == error_mark_node))
10224     return error_mark_node;
10225
10226   item = build (code, type, node1, node2, node3);
10227   TREE_SIDE_EFFECTS (item) = 1;
10228   return fold (item);
10229 }
10230
10231 #endif
10232
10233 /* ffecom_arg_expr -- Transform argument expr into gcc tree
10234
10235    See use by ffecom_list_expr.
10236
10237    If expression is NULL, returns an integer zero tree.  If it is not
10238    a CHARACTER expression, returns whatever ffecom_expr
10239    returns and sets the length return value to NULL_TREE.  Otherwise
10240    generates code to evaluate the character expression, returns the proper
10241    pointer to the result, but does NOT set the length return value to a tree
10242    that specifies the length of the result.  (In other words, the length
10243    variable is always set to NULL_TREE, because a length is never passed.)
10244
10245    21-Dec-91  JCB  1.1
10246       Don't set returned length, since nobody needs it (yet; someday if
10247       we allow CHARACTER*(*) dummies to statement functions, we'll need
10248       it).  */
10249
10250 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10251 tree
10252 ffecom_arg_expr (ffebld expr, tree *length)
10253 {
10254   tree ign;
10255
10256   *length = NULL_TREE;
10257
10258   if (expr == NULL)
10259     return integer_zero_node;
10260
10261   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10262     return ffecom_expr (expr);
10263
10264   return ffecom_arg_ptr_to_expr (expr, &ign);
10265 }
10266
10267 #endif
10268 /* Transform expression into constant argument-pointer-to-expression tree.
10269
10270    If the expression can be transformed into a argument-pointer-to-expression
10271    tree that is constant, that is done, and the tree returned.  Else
10272    NULL_TREE is returned.
10273
10274    That way, a caller can attempt to provide compile-time initialization
10275    of a variable and, if that fails, *then* choose to start a new block
10276    and resort to using temporaries, as appropriate.  */
10277
10278 tree
10279 ffecom_arg_ptr_to_const_expr (ffebld expr, tree *length)
10280 {
10281   if (! expr)
10282     return integer_zero_node;
10283
10284   if (ffebld_op (expr) == FFEBLD_opANY)
10285     {
10286       if (length)
10287         *length = error_mark_node;
10288       return error_mark_node;
10289     }
10290
10291   if (ffebld_arity (expr) == 0
10292       && (ffebld_op (expr) != FFEBLD_opSYMTER
10293           || ffebld_where (expr) == FFEINFO_whereCOMMON
10294           || ffebld_where (expr) == FFEINFO_whereGLOBAL
10295           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10296     {
10297       tree t;
10298
10299       t = ffecom_arg_ptr_to_expr (expr, length);
10300       assert (TREE_CONSTANT (t));
10301       assert (! length || TREE_CONSTANT (*length));
10302       return t;
10303     }
10304
10305   if (length
10306       && ffebld_size (expr) != FFETARGET_charactersizeNONE)
10307     *length = build_int_2 (ffebld_size (expr), 0);
10308   else if (length)
10309     *length = NULL_TREE;
10310   return NULL_TREE;
10311 }
10312
10313 /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
10314
10315    See use by ffecom_list_ptr_to_expr.
10316
10317    If expression is NULL, returns an integer zero tree.  If it is not
10318    a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10319    returns and sets the length return value to NULL_TREE.  Otherwise
10320    generates code to evaluate the character expression, returns the proper
10321    pointer to the result, AND sets the length return value to a tree that
10322    specifies the length of the result.
10323
10324    If the length argument is NULL, this is a slightly special
10325    case of building a FORMAT expression, that is, an expression that
10326    will be used at run time without regard to length.  For the current
10327    implementation, which uses the libf2c library, this means it is nice
10328    to append a null byte to the end of the expression, where feasible,
10329    to make sure any diagnostic about the FORMAT string terminates at
10330    some useful point.
10331
10332    For now, treat %REF(char-expr) as the same as char-expr with a NULL
10333    length argument.  This might even be seen as a feature, if a null
10334    byte can always be appended.  */
10335
10336 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10337 tree
10338 ffecom_arg_ptr_to_expr (ffebld expr, tree *length)
10339 {
10340   tree item;
10341   tree ign_length;
10342   ffecomConcatList_ catlist;
10343
10344   if (length != NULL)
10345     *length = NULL_TREE;
10346
10347   if (expr == NULL)
10348     return integer_zero_node;
10349
10350   switch (ffebld_op (expr))
10351     {
10352     case FFEBLD_opPERCENT_VAL:
10353       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10354         return ffecom_expr (ffebld_left (expr));
10355       {
10356         tree temp_exp;
10357         tree temp_length;
10358
10359         temp_exp = ffecom_arg_ptr_to_expr (ffebld_left (expr), &temp_length);
10360         if (temp_exp == error_mark_node)
10361           return error_mark_node;
10362
10363         return ffecom_1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (temp_exp)),
10364                          temp_exp);
10365       }
10366
10367     case FFEBLD_opPERCENT_REF:
10368       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10369         return ffecom_ptr_to_expr (ffebld_left (expr));
10370       if (length != NULL)
10371         {
10372           ign_length = NULL_TREE;
10373           length = &ign_length;
10374         }
10375       expr = ffebld_left (expr);
10376       break;
10377
10378     case FFEBLD_opPERCENT_DESCR:
10379       switch (ffeinfo_basictype (ffebld_info (expr)))
10380         {
10381 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10382         case FFEINFO_basictypeHOLLERITH:
10383 #endif
10384         case FFEINFO_basictypeCHARACTER:
10385           break;                /* Passed by descriptor anyway. */
10386
10387         default:
10388           item = ffecom_ptr_to_expr (expr);
10389           if (item != error_mark_node)
10390             *length = TYPE_SIZE (TREE_TYPE (TREE_TYPE (item)));
10391           break;
10392         }
10393       break;
10394
10395     default:
10396       break;
10397     }
10398
10399 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10400   if ((ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeHOLLERITH)
10401       && (length != NULL))
10402     {                           /* Pass Hollerith by descriptor. */
10403       ffetargetHollerith h;
10404
10405       assert (ffebld_op (expr) == FFEBLD_opCONTER);
10406       h = ffebld_cu_val_hollerith (ffebld_constant_union
10407                                    (ffebld_conter (expr)));
10408       *length
10409         = build_int_2 (h.length, 0);
10410       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10411     }
10412 #endif
10413
10414   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10415     return ffecom_ptr_to_expr (expr);
10416
10417   assert (ffeinfo_kindtype (ffebld_info (expr))
10418           == FFEINFO_kindtypeCHARACTER1);
10419
10420   while (ffebld_op (expr) == FFEBLD_opPAREN)
10421     expr = ffebld_left (expr);
10422
10423   catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
10424   switch (ffecom_concat_list_count_ (catlist))
10425     {
10426     case 0:                     /* Shouldn't happen, but in case it does... */
10427       if (length != NULL)
10428         {
10429           *length = ffecom_f2c_ftnlen_zero_node;
10430           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10431         }
10432       ffecom_concat_list_kill_ (catlist);
10433       return null_pointer_node;
10434
10435     case 1:                     /* The (fairly) easy case. */
10436       if (length == NULL)
10437         ffecom_char_args_with_null_ (&item, &ign_length,
10438                                      ffecom_concat_list_expr_ (catlist, 0));
10439       else
10440         ffecom_char_args_ (&item, length,
10441                            ffecom_concat_list_expr_ (catlist, 0));
10442       ffecom_concat_list_kill_ (catlist);
10443       assert (item != NULL_TREE);
10444       return item;
10445
10446     default:                    /* Must actually concatenate things. */
10447       break;
10448     }
10449
10450   {
10451     int count = ffecom_concat_list_count_ (catlist);
10452     int i;
10453     tree lengths;
10454     tree items;
10455     tree length_array;
10456     tree item_array;
10457     tree citem;
10458     tree clength;
10459     tree temporary;
10460     tree num;
10461     tree known_length;
10462     ffetargetCharacterSize sz;
10463
10464     sz = ffecom_concat_list_maxlen_ (catlist);
10465     /* ~~Kludge! */
10466     assert (sz != FFETARGET_charactersizeNONE);
10467
10468 #ifdef HOHO
10469     length_array
10470       = lengths
10471       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
10472                              FFETARGET_charactersizeNONE, count, TRUE);
10473     item_array
10474       = items
10475       = ffecom_push_tempvar (ffecom_f2c_address_type_node,
10476                              FFETARGET_charactersizeNONE, count, TRUE);
10477     temporary = ffecom_push_tempvar (char_type_node,
10478                                      sz, -1, TRUE);
10479 #else
10480     {
10481       tree hook;
10482
10483       hook = ffebld_nonter_hook (expr);
10484       assert (hook);
10485       assert (TREE_CODE (hook) == TREE_VEC);
10486       assert (TREE_VEC_LENGTH (hook) == 3);
10487       length_array = lengths = TREE_VEC_ELT (hook, 0);
10488       item_array = items = TREE_VEC_ELT (hook, 1);
10489       temporary = TREE_VEC_ELT (hook, 2);
10490     }
10491 #endif
10492
10493     known_length = ffecom_f2c_ftnlen_zero_node;
10494
10495     for (i = 0; i < count; ++i)
10496       {
10497         if ((i == count)
10498             && (length == NULL))
10499           ffecom_char_args_with_null_ (&citem, &clength,
10500                                        ffecom_concat_list_expr_ (catlist, i));
10501         else
10502           ffecom_char_args_ (&citem, &clength,
10503                              ffecom_concat_list_expr_ (catlist, i));
10504         if ((citem == error_mark_node)
10505             || (clength == error_mark_node))
10506           {
10507             ffecom_concat_list_kill_ (catlist);
10508             *length = error_mark_node;
10509             return error_mark_node;
10510           }
10511
10512         items
10513           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
10514                       ffecom_modify (void_type_node,
10515                                      ffecom_2 (ARRAY_REF,
10516                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
10517                                                item_array,
10518                                                build_int_2 (i, 0)),
10519                                      citem),
10520                       items);
10521         clength = ffecom_save_tree (clength);
10522         if (length != NULL)
10523           known_length
10524             = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
10525                         known_length,
10526                         clength);
10527         lengths
10528           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
10529                       ffecom_modify (void_type_node,
10530                                      ffecom_2 (ARRAY_REF,
10531                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
10532                                                length_array,
10533                                                build_int_2 (i, 0)),
10534                                      clength),
10535                       lengths);
10536       }
10537
10538     temporary = ffecom_1 (ADDR_EXPR,
10539                           build_pointer_type (TREE_TYPE (temporary)),
10540                           temporary);
10541
10542     item = build_tree_list (NULL_TREE, temporary);
10543     TREE_CHAIN (item)
10544       = build_tree_list (NULL_TREE,
10545                          ffecom_1 (ADDR_EXPR,
10546                                    build_pointer_type (TREE_TYPE (items)),
10547                                    items));
10548     TREE_CHAIN (TREE_CHAIN (item))
10549       = build_tree_list (NULL_TREE,
10550                          ffecom_1 (ADDR_EXPR,
10551                                    build_pointer_type (TREE_TYPE (lengths)),
10552                                    lengths));
10553     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
10554       = build_tree_list
10555         (NULL_TREE,
10556          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
10557                    convert (ffecom_f2c_ftnlen_type_node,
10558                             build_int_2 (count, 0))));
10559     num = build_int_2 (sz, 0);
10560     TREE_TYPE (num) = ffecom_f2c_ftnlen_type_node;
10561     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item))))
10562       = build_tree_list (NULL_TREE, num);
10563
10564     item = ffecom_call_gfrt (FFECOM_gfrtCAT, item, NULL_TREE);
10565     TREE_SIDE_EFFECTS (item) = 1;
10566     item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (temporary),
10567                      item,
10568                      temporary);
10569
10570     if (length != NULL)
10571       *length = known_length;
10572   }
10573
10574   ffecom_concat_list_kill_ (catlist);
10575   assert (item != NULL_TREE);
10576   return item;
10577 }
10578
10579 #endif
10580 /* Generate call to run-time function.
10581
10582    The first arg is the GNU Fortran Run-Time function index, the second
10583    arg is the list of arguments to pass to it.  Returned is the expression
10584    (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
10585    result (which may be void).  */
10586
10587 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10588 tree
10589 ffecom_call_gfrt (ffecomGfrt ix, tree args, tree hook)
10590 {
10591   return ffecom_call_ (ffecom_gfrt_tree_ (ix),
10592                        ffecom_gfrt_kindtype (ix),
10593                        ffe_is_f2c_library () && ffecom_gfrt_complex_[ix],
10594                        NULL_TREE, args, NULL_TREE, NULL,
10595                        NULL, NULL_TREE, TRUE, hook);
10596 }
10597 #endif
10598
10599 /* Transform constant-union to tree.  */
10600
10601 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10602 tree
10603 ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt,
10604                       ffeinfoKindtype kt, tree tree_type)
10605 {
10606   tree item;
10607
10608   switch (bt)
10609     {
10610     case FFEINFO_basictypeINTEGER:
10611       {
10612         int val;
10613
10614         switch (kt)
10615           {
10616 #if FFETARGET_okINTEGER1
10617           case FFEINFO_kindtypeINTEGER1:
10618             val = ffebld_cu_val_integer1 (*cu);
10619             break;
10620 #endif
10621
10622 #if FFETARGET_okINTEGER2
10623           case FFEINFO_kindtypeINTEGER2:
10624             val = ffebld_cu_val_integer2 (*cu);
10625             break;
10626 #endif
10627
10628 #if FFETARGET_okINTEGER3
10629           case FFEINFO_kindtypeINTEGER3:
10630             val = ffebld_cu_val_integer3 (*cu);
10631             break;
10632 #endif
10633
10634 #if FFETARGET_okINTEGER4
10635           case FFEINFO_kindtypeINTEGER4:
10636             val = ffebld_cu_val_integer4 (*cu);
10637             break;
10638 #endif
10639
10640           default:
10641             assert ("bad INTEGER constant kind type" == NULL);
10642             /* Fall through. */
10643           case FFEINFO_kindtypeANY:
10644             return error_mark_node;
10645           }
10646         item = build_int_2 (val, (val < 0) ? -1 : 0);
10647         TREE_TYPE (item) = tree_type;
10648       }
10649       break;
10650
10651     case FFEINFO_basictypeLOGICAL:
10652       {
10653         int val;
10654
10655         switch (kt)
10656           {
10657 #if FFETARGET_okLOGICAL1
10658           case FFEINFO_kindtypeLOGICAL1:
10659             val = ffebld_cu_val_logical1 (*cu);
10660             break;
10661 #endif
10662
10663 #if FFETARGET_okLOGICAL2
10664           case FFEINFO_kindtypeLOGICAL2:
10665             val = ffebld_cu_val_logical2 (*cu);
10666             break;
10667 #endif
10668
10669 #if FFETARGET_okLOGICAL3
10670           case FFEINFO_kindtypeLOGICAL3:
10671             val = ffebld_cu_val_logical3 (*cu);
10672             break;
10673 #endif
10674
10675 #if FFETARGET_okLOGICAL4
10676           case FFEINFO_kindtypeLOGICAL4:
10677             val = ffebld_cu_val_logical4 (*cu);
10678             break;
10679 #endif
10680
10681           default:
10682             assert ("bad LOGICAL constant kind type" == NULL);
10683             /* Fall through. */
10684           case FFEINFO_kindtypeANY:
10685             return error_mark_node;
10686           }
10687         item = build_int_2 (val, (val < 0) ? -1 : 0);
10688         TREE_TYPE (item) = tree_type;
10689       }
10690       break;
10691
10692     case FFEINFO_basictypeREAL:
10693       {
10694         REAL_VALUE_TYPE val;
10695
10696         switch (kt)
10697           {
10698 #if FFETARGET_okREAL1
10699           case FFEINFO_kindtypeREAL1:
10700             val = ffetarget_value_real1 (ffebld_cu_val_real1 (*cu));
10701             break;
10702 #endif
10703
10704 #if FFETARGET_okREAL2
10705           case FFEINFO_kindtypeREAL2:
10706             val = ffetarget_value_real2 (ffebld_cu_val_real2 (*cu));
10707             break;
10708 #endif
10709
10710 #if FFETARGET_okREAL3
10711           case FFEINFO_kindtypeREAL3:
10712             val = ffetarget_value_real3 (ffebld_cu_val_real3 (*cu));
10713             break;
10714 #endif
10715
10716 #if FFETARGET_okREAL4
10717           case FFEINFO_kindtypeREAL4:
10718             val = ffetarget_value_real4 (ffebld_cu_val_real4 (*cu));
10719             break;
10720 #endif
10721
10722           default:
10723             assert ("bad REAL constant kind type" == NULL);
10724             /* Fall through. */
10725           case FFEINFO_kindtypeANY:
10726             return error_mark_node;
10727           }
10728         item = build_real (tree_type, val);
10729       }
10730       break;
10731
10732     case FFEINFO_basictypeCOMPLEX:
10733       {
10734         REAL_VALUE_TYPE real;
10735         REAL_VALUE_TYPE imag;
10736         tree el_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
10737
10738         switch (kt)
10739           {
10740 #if FFETARGET_okCOMPLEX1
10741           case FFEINFO_kindtypeREAL1:
10742             real = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).real);
10743             imag = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).imaginary);
10744             break;
10745 #endif
10746
10747 #if FFETARGET_okCOMPLEX2
10748           case FFEINFO_kindtypeREAL2:
10749             real = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).real);
10750             imag = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).imaginary);
10751             break;
10752 #endif
10753
10754 #if FFETARGET_okCOMPLEX3
10755           case FFEINFO_kindtypeREAL3:
10756             real = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).real);
10757             imag = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).imaginary);
10758             break;
10759 #endif
10760
10761 #if FFETARGET_okCOMPLEX4
10762           case FFEINFO_kindtypeREAL4:
10763             real = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).real);
10764             imag = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).imaginary);
10765             break;
10766 #endif
10767
10768           default:
10769             assert ("bad REAL constant kind type" == NULL);
10770             /* Fall through. */
10771           case FFEINFO_kindtypeANY:
10772             return error_mark_node;
10773           }
10774         item = ffecom_build_complex_constant_ (tree_type,
10775                                                build_real (el_type, real),
10776                                                build_real (el_type, imag));
10777       }
10778       break;
10779
10780     case FFEINFO_basictypeCHARACTER:
10781       {                         /* Happens only in DATA and similar contexts. */
10782         ffetargetCharacter1 val;
10783
10784         switch (kt)
10785           {
10786 #if FFETARGET_okCHARACTER1
10787           case FFEINFO_kindtypeLOGICAL1:
10788             val = ffebld_cu_val_character1 (*cu);
10789             break;
10790 #endif
10791
10792           default:
10793             assert ("bad CHARACTER constant kind type" == NULL);
10794             /* Fall through. */
10795           case FFEINFO_kindtypeANY:
10796             return error_mark_node;
10797           }
10798         item = build_string (ffetarget_length_character1 (val),
10799                              ffetarget_text_character1 (val));
10800         TREE_TYPE (item)
10801           = build_type_variant (build_array_type (char_type_node,
10802                                                   build_range_type
10803                                                   (integer_type_node,
10804                                                    integer_one_node,
10805                                                    build_int_2
10806                                                 (ffetarget_length_character1
10807                                                  (val), 0))),
10808                                 1, 0);
10809       }
10810       break;
10811
10812     case FFEINFO_basictypeHOLLERITH:
10813       {
10814         ffetargetHollerith h;
10815
10816         h = ffebld_cu_val_hollerith (*cu);
10817
10818         /* If not at least as wide as default INTEGER, widen it.  */
10819         if (h.length >= FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE)
10820           item = build_string (h.length, h.text);
10821         else
10822           {
10823             char str[FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE];
10824
10825             memcpy (str, h.text, h.length);
10826             memset (&str[h.length], ' ',
10827                     FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE
10828                     - h.length);
10829             item = build_string (FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE,
10830                                  str);
10831           }
10832         TREE_TYPE (item)
10833           = build_type_variant (build_array_type (char_type_node,
10834                                                   build_range_type
10835                                                   (integer_type_node,
10836                                                    integer_one_node,
10837                                                    build_int_2
10838                                                    (h.length, 0))),
10839                                 1, 0);
10840       }
10841       break;
10842
10843     case FFEINFO_basictypeTYPELESS:
10844       {
10845         ffetargetInteger1 ival;
10846         ffetargetTypeless tless;
10847         ffebad error;
10848
10849         tless = ffebld_cu_val_typeless (*cu);
10850         error = ffetarget_convert_integer1_typeless (&ival, tless);
10851         assert (error == FFEBAD);
10852
10853         item = build_int_2 ((int) ival, 0);
10854       }
10855       break;
10856
10857     default:
10858       assert ("not yet on constant type" == NULL);
10859       /* Fall through. */
10860     case FFEINFO_basictypeANY:
10861       return error_mark_node;
10862     }
10863
10864   TREE_CONSTANT (item) = 1;
10865
10866   return item;
10867 }
10868
10869 #endif
10870
10871 /* Transform expression into constant tree.
10872
10873    If the expression can be transformed into a tree that is constant,
10874    that is done, and the tree returned.  Else NULL_TREE is returned.
10875
10876    That way, a caller can attempt to provide compile-time initialization
10877    of a variable and, if that fails, *then* choose to start a new block
10878    and resort to using temporaries, as appropriate.  */
10879
10880 tree
10881 ffecom_const_expr (ffebld expr)
10882 {
10883   if (! expr)
10884     return integer_zero_node;
10885
10886   if (ffebld_op (expr) == FFEBLD_opANY)
10887     return error_mark_node;
10888
10889   if (ffebld_arity (expr) == 0
10890       && (ffebld_op (expr) != FFEBLD_opSYMTER
10891 #if NEWCOMMON
10892           /* ~~Enable once common/equivalence is handled properly?  */
10893           || ffebld_where (expr) == FFEINFO_whereCOMMON
10894 #endif
10895           || ffebld_where (expr) == FFEINFO_whereGLOBAL
10896           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10897     {
10898       tree t;
10899
10900       t = ffecom_expr (expr);
10901       assert (TREE_CONSTANT (t));
10902       return t;
10903     }
10904
10905   return NULL_TREE;
10906 }
10907
10908 /* Handy way to make a field in a struct/union.  */
10909
10910 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10911 tree
10912 ffecom_decl_field (tree context, tree prevfield,
10913                    const char *name, tree type)
10914 {
10915   tree field;
10916
10917   field = build_decl (FIELD_DECL, get_identifier (name), type);
10918   DECL_CONTEXT (field) = context;
10919   DECL_ALIGN (field) = 0;
10920   DECL_USER_ALIGN (field) = 0;
10921   if (prevfield != NULL_TREE)
10922     TREE_CHAIN (prevfield) = field;
10923
10924   return field;
10925 }
10926
10927 #endif
10928
10929 void
10930 ffecom_close_include (FILE *f)
10931 {
10932 #if FFECOM_GCC_INCLUDE
10933   ffecom_close_include_ (f);
10934 #endif
10935 }
10936
10937 int
10938 ffecom_decode_include_option (char *spec)
10939 {
10940 #if FFECOM_GCC_INCLUDE
10941   return ffecom_decode_include_option_ (spec);
10942 #else
10943   return 1;
10944 #endif
10945 }
10946
10947 /* End a compound statement (block).  */
10948
10949 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10950 tree
10951 ffecom_end_compstmt (void)
10952 {
10953   return bison_rule_compstmt_ ();
10954 }
10955 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
10956
10957 /* ffecom_end_transition -- Perform end transition on all symbols
10958
10959    ffecom_end_transition();
10960
10961    Calls ffecom_sym_end_transition for each global and local symbol.  */
10962
10963 void
10964 ffecom_end_transition ()
10965 {
10966 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10967   ffebld item;
10968 #endif
10969
10970   if (ffe_is_ffedebug ())
10971     fprintf (dmpout, "; end_stmt_transition\n");
10972
10973 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10974   ffecom_list_blockdata_ = NULL;
10975   ffecom_list_common_ = NULL;
10976 #endif
10977
10978   ffesymbol_drive (ffecom_sym_end_transition);
10979   if (ffe_is_ffedebug ())
10980     {
10981       ffestorag_report ();
10982 #if FFECOM_targetCURRENT == FFECOM_targetFFE
10983       ffesymbol_report_all ();
10984 #endif
10985     }
10986
10987 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10988   ffecom_start_progunit_ ();
10989
10990   for (item = ffecom_list_blockdata_;
10991        item != NULL;
10992        item = ffebld_trail (item))
10993     {
10994       ffebld callee;
10995       ffesymbol s;
10996       tree dt;
10997       tree t;
10998       tree var;
10999       static int number = 0;
11000
11001       callee = ffebld_head (item);
11002       s = ffebld_symter (callee);
11003       t = ffesymbol_hook (s).decl_tree;
11004       if (t == NULL_TREE)
11005         {
11006           s = ffecom_sym_transform_ (s);
11007           t = ffesymbol_hook (s).decl_tree;
11008         }
11009
11010       dt = build_pointer_type (TREE_TYPE (t));
11011
11012       var = build_decl (VAR_DECL,
11013                         ffecom_get_invented_identifier ("__g77_forceload_%d",
11014                                                         number++),
11015                         dt);
11016       DECL_EXTERNAL (var) = 0;
11017       TREE_STATIC (var) = 1;
11018       TREE_PUBLIC (var) = 0;
11019       DECL_INITIAL (var) = error_mark_node;
11020       TREE_USED (var) = 1;
11021
11022       var = start_decl (var, FALSE);
11023
11024       t = ffecom_1 (ADDR_EXPR, dt, t);
11025
11026       finish_decl (var, t, FALSE);
11027     }
11028
11029   /* This handles any COMMON areas that weren't referenced but have, for
11030      example, important initial data.  */
11031
11032   for (item = ffecom_list_common_;
11033        item != NULL;
11034        item = ffebld_trail (item))
11035     ffecom_transform_common_ (ffebld_symter (ffebld_head (item)));
11036
11037   ffecom_list_common_ = NULL;
11038 #endif
11039 }
11040
11041 /* ffecom_exec_transition -- Perform exec transition on all symbols
11042
11043    ffecom_exec_transition();
11044
11045    Calls ffecom_sym_exec_transition for each global and local symbol.
11046    Make sure error updating not inhibited.  */
11047
11048 void
11049 ffecom_exec_transition ()
11050 {
11051   bool inhibited;
11052
11053   if (ffe_is_ffedebug ())
11054     fprintf (dmpout, "; exec_stmt_transition\n");
11055
11056   inhibited = ffebad_inhibit ();
11057   ffebad_set_inhibit (FALSE);
11058
11059   ffesymbol_drive (ffecom_sym_exec_transition); /* Don't retract! */
11060   ffeequiv_exec_transition ();  /* Handle all pending EQUIVALENCEs. */
11061   if (ffe_is_ffedebug ())
11062     {
11063       ffestorag_report ();
11064 #if FFECOM_targetCURRENT == FFECOM_targetFFE
11065       ffesymbol_report_all ();
11066 #endif
11067     }
11068
11069   if (inhibited)
11070     ffebad_set_inhibit (TRUE);
11071 }
11072
11073 /* Handle assignment statement.
11074
11075    Convert dest and source using ffecom_expr, then join them
11076    with an ASSIGN op and pass the whole thing to expand_expr_stmt.  */
11077
11078 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11079 void
11080 ffecom_expand_let_stmt (ffebld dest, ffebld source)
11081 {
11082   tree dest_tree;
11083   tree dest_length;
11084   tree source_tree;
11085   tree expr_tree;
11086
11087   if (ffeinfo_basictype (ffebld_info (dest)) != FFEINFO_basictypeCHARACTER)
11088     {
11089       bool dest_used;
11090       tree assign_temp;
11091
11092       /* This attempts to replicate the test below, but must not be
11093          true when the test below is false.  (Always err on the side
11094          of creating unused temporaries, to avoid ICEs.)  */
11095       if (ffebld_op (dest) != FFEBLD_opSYMTER
11096           || ((dest_tree = ffesymbol_hook (ffebld_symter (dest)).decl_tree)
11097               && (TREE_CODE (dest_tree) != VAR_DECL
11098                   || TREE_ADDRESSABLE (dest_tree))))
11099         {
11100           ffecom_prepare_expr_ (source, dest);
11101           dest_used = TRUE;
11102         }
11103       else
11104         {
11105           ffecom_prepare_expr_ (source, NULL);
11106           dest_used = FALSE;
11107         }
11108
11109       ffecom_prepare_expr_w (NULL_TREE, dest);
11110
11111       /* For COMPLEX assignment like C1=C2, if partial overlap is possible,
11112          create a temporary through which the assignment is to take place,
11113          since MODIFY_EXPR doesn't handle partial overlap properly.  */
11114       if (ffebld_basictype (dest) == FFEINFO_basictypeCOMPLEX
11115           && ffecom_possible_partial_overlap_ (dest, source))
11116         {
11117           assign_temp = ffecom_make_tempvar ("complex_let",
11118                                              ffecom_tree_type
11119                                              [ffebld_basictype (dest)]
11120                                              [ffebld_kindtype (dest)],
11121                                              FFETARGET_charactersizeNONE,
11122                                              -1);
11123         }
11124       else
11125         assign_temp = NULL_TREE;
11126
11127       ffecom_prepare_end ();
11128
11129       dest_tree = ffecom_expr_w (NULL_TREE, dest);
11130       if (dest_tree == error_mark_node)
11131         return;
11132
11133       if ((TREE_CODE (dest_tree) != VAR_DECL)
11134           || TREE_ADDRESSABLE (dest_tree))
11135         source_tree = ffecom_expr_ (source, dest_tree, dest, &dest_used,
11136                                     FALSE, FALSE);
11137       else
11138         {
11139           assert (! dest_used);
11140           dest_used = FALSE;
11141           source_tree = ffecom_expr (source);
11142         }
11143       if (source_tree == error_mark_node)
11144         return;
11145
11146       if (dest_used)
11147         expr_tree = source_tree;
11148       else if (assign_temp)
11149         {
11150 #ifdef MOVE_EXPR
11151           /* The back end understands a conceptual move (evaluate source;
11152              store into dest), so use that, in case it can determine
11153              that it is going to use, say, two registers as temporaries
11154              anyway.  So don't use the temp (and someday avoid generating
11155              it, once this code starts triggering regularly).  */
11156           expr_tree = ffecom_2s (MOVE_EXPR, void_type_node,
11157                                  dest_tree,
11158                                  source_tree);
11159 #else
11160           expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11161                                  assign_temp,
11162                                  source_tree);
11163           expand_expr_stmt (expr_tree);
11164           expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11165                                  dest_tree,
11166                                  assign_temp);
11167 #endif
11168         }
11169       else
11170         expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11171                                dest_tree,
11172                                source_tree);
11173
11174       expand_expr_stmt (expr_tree);
11175       return;
11176     }
11177
11178   ffecom_prepare_let_char_ (ffebld_size_known (dest), source);
11179   ffecom_prepare_expr_w (NULL_TREE, dest);
11180
11181   ffecom_prepare_end ();
11182
11183   ffecom_char_args_ (&dest_tree, &dest_length, dest);
11184   ffecom_let_char_ (dest_tree, dest_length, ffebld_size_known (dest),
11185                     source);
11186 }
11187
11188 #endif
11189 /* ffecom_expr -- Transform expr into gcc tree
11190
11191    tree t;
11192    ffebld expr;  // FFE expression.
11193    tree = ffecom_expr(expr);
11194
11195    Recursive descent on expr while making corresponding tree nodes and
11196    attaching type info and such.  */
11197
11198 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11199 tree
11200 ffecom_expr (ffebld expr)
11201 {
11202   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, FALSE, FALSE);
11203 }
11204
11205 #endif
11206 /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT.  */
11207
11208 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11209 tree
11210 ffecom_expr_assign (ffebld expr)
11211 {
11212   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
11213 }
11214
11215 #endif
11216 /* Like ffecom_expr_rw, but return tree usable for ASSIGN.  */
11217
11218 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11219 tree
11220 ffecom_expr_assign_w (ffebld expr)
11221 {
11222   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
11223 }
11224
11225 #endif
11226 /* Transform expr for use as into read/write tree and stabilize the
11227    reference.  Not for use on CHARACTER expressions.
11228
11229    Recursive descent on expr while making corresponding tree nodes and
11230    attaching type info and such.  */
11231
11232 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11233 tree
11234 ffecom_expr_rw (tree type, ffebld expr)
11235 {
11236   assert (expr != NULL);
11237   /* Different target types not yet supported.  */
11238   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
11239
11240   return stabilize_reference (ffecom_expr (expr));
11241 }
11242
11243 #endif
11244 /* Transform expr for use as into write tree and stabilize the
11245    reference.  Not for use on CHARACTER expressions.
11246
11247    Recursive descent on expr while making corresponding tree nodes and
11248    attaching type info and such.  */
11249
11250 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11251 tree
11252 ffecom_expr_w (tree type, ffebld expr)
11253 {
11254   assert (expr != NULL);
11255   /* Different target types not yet supported.  */
11256   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
11257
11258   return stabilize_reference (ffecom_expr (expr));
11259 }
11260
11261 #endif
11262 /* Do global stuff.  */
11263
11264 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11265 void
11266 ffecom_finish_compile ()
11267 {
11268   assert (ffecom_outer_function_decl_ == NULL_TREE);
11269   assert (current_function_decl == NULL_TREE);
11270
11271   ffeglobal_drive (ffecom_finish_global_);
11272 }
11273
11274 #endif
11275 /* Public entry point for front end to access finish_decl.  */
11276
11277 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11278 void
11279 ffecom_finish_decl (tree decl, tree init, bool is_top_level)
11280 {
11281   assert (!is_top_level);
11282   finish_decl (decl, init, FALSE);
11283 }
11284
11285 #endif
11286 /* Finish a program unit.  */
11287
11288 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11289 void
11290 ffecom_finish_progunit ()
11291 {
11292   ffecom_end_compstmt ();
11293
11294   ffecom_previous_function_decl_ = current_function_decl;
11295   ffecom_which_entrypoint_decl_ = NULL_TREE;
11296
11297   finish_function (0);
11298 }
11299
11300 #endif
11301
11302 /* Wrapper for get_identifier.  pattern is sprintf-like.  */
11303
11304 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11305 tree
11306 ffecom_get_invented_identifier (const char *pattern, ...)
11307 {
11308   tree decl;
11309   char *nam;
11310   va_list ap;
11311
11312   va_start (ap, pattern);
11313   if (vasprintf (&nam, pattern, ap) == 0)
11314     abort ();
11315   va_end (ap);
11316   decl = get_identifier (nam);
11317   free (nam);
11318   IDENTIFIER_INVENTED (decl) = 1;
11319   return decl;
11320 }
11321
11322 ffeinfoBasictype
11323 ffecom_gfrt_basictype (ffecomGfrt gfrt)
11324 {
11325   assert (gfrt < FFECOM_gfrt);
11326
11327   switch (ffecom_gfrt_type_[gfrt])
11328     {
11329     case FFECOM_rttypeVOID_:
11330     case FFECOM_rttypeVOIDSTAR_:
11331       return FFEINFO_basictypeNONE;
11332
11333     case FFECOM_rttypeFTNINT_:
11334       return FFEINFO_basictypeINTEGER;
11335
11336     case FFECOM_rttypeINTEGER_:
11337       return FFEINFO_basictypeINTEGER;
11338
11339     case FFECOM_rttypeLONGINT_:
11340       return FFEINFO_basictypeINTEGER;
11341
11342     case FFECOM_rttypeLOGICAL_:
11343       return FFEINFO_basictypeLOGICAL;
11344
11345     case FFECOM_rttypeREAL_F2C_:
11346     case FFECOM_rttypeREAL_GNU_:
11347       return FFEINFO_basictypeREAL;
11348
11349     case FFECOM_rttypeCOMPLEX_F2C_:
11350     case FFECOM_rttypeCOMPLEX_GNU_:
11351       return FFEINFO_basictypeCOMPLEX;
11352
11353     case FFECOM_rttypeDOUBLE_:
11354     case FFECOM_rttypeDOUBLEREAL_:
11355       return FFEINFO_basictypeREAL;
11356
11357     case FFECOM_rttypeDBLCMPLX_F2C_:
11358     case FFECOM_rttypeDBLCMPLX_GNU_:
11359       return FFEINFO_basictypeCOMPLEX;
11360
11361     case FFECOM_rttypeCHARACTER_:
11362       return FFEINFO_basictypeCHARACTER;
11363
11364     default:
11365       return FFEINFO_basictypeANY;
11366     }
11367 }
11368
11369 ffeinfoKindtype
11370 ffecom_gfrt_kindtype (ffecomGfrt gfrt)
11371 {
11372   assert (gfrt < FFECOM_gfrt);
11373
11374   switch (ffecom_gfrt_type_[gfrt])
11375     {
11376     case FFECOM_rttypeVOID_:
11377     case FFECOM_rttypeVOIDSTAR_:
11378       return FFEINFO_kindtypeNONE;
11379
11380     case FFECOM_rttypeFTNINT_:
11381       return FFEINFO_kindtypeINTEGER1;
11382
11383     case FFECOM_rttypeINTEGER_:
11384       return FFEINFO_kindtypeINTEGER1;
11385
11386     case FFECOM_rttypeLONGINT_:
11387       return FFEINFO_kindtypeINTEGER4;
11388
11389     case FFECOM_rttypeLOGICAL_:
11390       return FFEINFO_kindtypeLOGICAL1;
11391
11392     case FFECOM_rttypeREAL_F2C_:
11393     case FFECOM_rttypeREAL_GNU_:
11394       return FFEINFO_kindtypeREAL1;
11395
11396     case FFECOM_rttypeCOMPLEX_F2C_:
11397     case FFECOM_rttypeCOMPLEX_GNU_:
11398       return FFEINFO_kindtypeREAL1;
11399
11400     case FFECOM_rttypeDOUBLE_:
11401     case FFECOM_rttypeDOUBLEREAL_:
11402       return FFEINFO_kindtypeREAL2;
11403
11404     case FFECOM_rttypeDBLCMPLX_F2C_:
11405     case FFECOM_rttypeDBLCMPLX_GNU_:
11406       return FFEINFO_kindtypeREAL2;
11407
11408     case FFECOM_rttypeCHARACTER_:
11409       return FFEINFO_kindtypeCHARACTER1;
11410
11411     default:
11412       return FFEINFO_kindtypeANY;
11413     }
11414 }
11415
11416 void
11417 ffecom_init_0 ()
11418 {
11419   tree endlink;
11420   int i;
11421   int j;
11422   tree t;
11423   tree field;
11424   ffetype type;
11425   ffetype base_type;
11426   tree double_ftype_double;
11427   tree float_ftype_float;
11428   tree ldouble_ftype_ldouble;
11429   tree ffecom_tree_ptr_to_fun_type_void;
11430
11431   /* This block of code comes from the now-obsolete cktyps.c.  It checks
11432      whether the compiler environment is buggy in known ways, some of which
11433      would, if not explicitly checked here, result in subtle bugs in g77.  */
11434
11435   if (ffe_is_do_internal_checks ())
11436     {
11437       static char names[][12]
11438         =
11439       {"bar", "bletch", "foo", "foobar"};
11440       char *name;
11441       unsigned long ul;
11442       double fl;
11443
11444       name = bsearch ("foo", &names[0], ARRAY_SIZE (names), sizeof (names[0]),
11445                       (int (*)(const void *, const void *)) strcmp);
11446       if (name != (char *) &names[2])
11447         {
11448           assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
11449                   == NULL);
11450           abort ();
11451         }
11452
11453       ul = strtoul ("123456789", NULL, 10);
11454       if (ul != 123456789L)
11455         {
11456           assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\
11457  in proj.h" == NULL);
11458           abort ();
11459         }
11460
11461       fl = atof ("56.789");
11462       if ((fl < 56.788) || (fl > 56.79))
11463         {
11464           assert ("atof not type double, fix your #include <stdio.h>"
11465                   == NULL);
11466           abort ();
11467         }
11468     }
11469
11470 #if FFECOM_GCC_INCLUDE
11471   ffecom_initialize_char_syntax_ ();
11472 #endif
11473
11474   ffecom_outer_function_decl_ = NULL_TREE;
11475   current_function_decl = NULL_TREE;
11476   named_labels = NULL_TREE;
11477   current_binding_level = NULL_BINDING_LEVEL;
11478   free_binding_level = NULL_BINDING_LEVEL;
11479   /* Make the binding_level structure for global names.  */
11480   pushlevel (0);
11481   global_binding_level = current_binding_level;
11482   current_binding_level->prep_state = 2;
11483
11484   build_common_tree_nodes (1);
11485
11486   /* Define `int' and `char' first so that dbx will output them first.  */
11487   pushdecl (build_decl (TYPE_DECL, get_identifier ("int"),
11488                         integer_type_node));
11489   pushdecl (build_decl (TYPE_DECL, get_identifier ("char"),
11490                         char_type_node));
11491   pushdecl (build_decl (TYPE_DECL, get_identifier ("long int"),
11492                         long_integer_type_node));
11493   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"),
11494                         unsigned_type_node));
11495   pushdecl (build_decl (TYPE_DECL, get_identifier ("long unsigned int"),
11496                         long_unsigned_type_node));
11497   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long int"),
11498                         long_long_integer_type_node));
11499   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long unsigned int"),
11500                         long_long_unsigned_type_node));
11501   pushdecl (build_decl (TYPE_DECL, get_identifier ("short int"),
11502                         short_integer_type_node));
11503   pushdecl (build_decl (TYPE_DECL, get_identifier ("short unsigned int"),
11504                         short_unsigned_type_node));
11505
11506   /* Set the sizetype before we make other types.  This *should* be the
11507      first type we create.  */
11508
11509   set_sizetype
11510     (TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE))));
11511   ffecom_typesize_pointer_
11512     = TREE_INT_CST_LOW (TYPE_SIZE (sizetype)) / BITS_PER_UNIT;
11513
11514   build_common_tree_nodes_2 (0);
11515
11516   /* Define both `signed char' and `unsigned char'.  */
11517   pushdecl (build_decl (TYPE_DECL, get_identifier ("signed char"),
11518                         signed_char_type_node));
11519
11520   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"),
11521                         unsigned_char_type_node));
11522
11523   pushdecl (build_decl (TYPE_DECL, get_identifier ("float"),
11524                         float_type_node));
11525   pushdecl (build_decl (TYPE_DECL, get_identifier ("double"),
11526                         double_type_node));
11527   pushdecl (build_decl (TYPE_DECL, get_identifier ("long double"),
11528                         long_double_type_node));
11529
11530   /* For now, override what build_common_tree_nodes has done.  */
11531   complex_integer_type_node = ffecom_make_complex_type_ (integer_type_node);
11532   complex_float_type_node = ffecom_make_complex_type_ (float_type_node);
11533   complex_double_type_node = ffecom_make_complex_type_ (double_type_node);
11534   complex_long_double_type_node
11535     = ffecom_make_complex_type_ (long_double_type_node);
11536
11537   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex int"),
11538                         complex_integer_type_node));
11539   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex float"),
11540                         complex_float_type_node));
11541   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex double"),
11542                         complex_double_type_node));
11543   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex long double"),
11544                         complex_long_double_type_node));
11545
11546   pushdecl (build_decl (TYPE_DECL, get_identifier ("void"),
11547                         void_type_node));
11548   /* We are not going to have real types in C with less than byte alignment,
11549      so we might as well not have any types that claim to have it.  */
11550   TYPE_ALIGN (void_type_node) = BITS_PER_UNIT;
11551   TYPE_USER_ALIGN (void_type_node) = 0;
11552
11553   string_type_node = build_pointer_type (char_type_node);
11554
11555   ffecom_tree_fun_type_void
11556     = build_function_type (void_type_node, NULL_TREE);
11557
11558   ffecom_tree_ptr_to_fun_type_void
11559     = build_pointer_type (ffecom_tree_fun_type_void);
11560
11561   endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
11562
11563   float_ftype_float
11564     = build_function_type (float_type_node,
11565                            tree_cons (NULL_TREE, float_type_node, endlink));
11566
11567   double_ftype_double
11568     = build_function_type (double_type_node,
11569                            tree_cons (NULL_TREE, double_type_node, endlink));
11570
11571   ldouble_ftype_ldouble
11572     = build_function_type (long_double_type_node,
11573                            tree_cons (NULL_TREE, long_double_type_node,
11574                                       endlink));
11575
11576   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11577     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11578       {
11579         ffecom_tree_type[i][j] = NULL_TREE;
11580         ffecom_tree_fun_type[i][j] = NULL_TREE;
11581         ffecom_tree_ptr_to_fun_type[i][j] = NULL_TREE;
11582         ffecom_f2c_typecode_[i][j] = -1;
11583       }
11584
11585   /* Set up standard g77 types.  Note that INTEGER and LOGICAL are set
11586      to size FLOAT_TYPE_SIZE because they have to be the same size as
11587      REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
11588      Compiler options and other such stuff that change the ways these
11589      types are set should not affect this particular setup.  */
11590
11591   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1]
11592     = t = make_signed_type (FLOAT_TYPE_SIZE);
11593   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer"),
11594                         t));
11595   type = ffetype_new ();
11596   base_type = type;
11597   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER1,
11598                     type);
11599   ffetype_set_ams (type,
11600                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11601                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11602   ffetype_set_star (base_type,
11603                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11604                     type);
11605   ffetype_set_kind (base_type, 1, type);
11606   ffecom_typesize_integer1_ = ffetype_size (type);
11607   assert (ffetype_size (type) == sizeof (ffetargetInteger1));
11608
11609   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER1]
11610     = t = make_unsigned_type (FLOAT_TYPE_SIZE); /* HOLLERITH means unsigned. */
11611   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned"),
11612                         t));
11613
11614   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER2]
11615     = t = make_signed_type (CHAR_TYPE_SIZE);
11616   pushdecl (build_decl (TYPE_DECL, get_identifier ("byte"),
11617                         t));
11618   type = ffetype_new ();
11619   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER2,
11620                     type);
11621   ffetype_set_ams (type,
11622                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11623                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11624   ffetype_set_star (base_type,
11625                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11626                     type);
11627   ffetype_set_kind (base_type, 3, type);
11628   assert (ffetype_size (type) == sizeof (ffetargetInteger2));
11629
11630   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER2]
11631     = t = make_unsigned_type (CHAR_TYPE_SIZE);
11632   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned byte"),
11633                         t));
11634
11635   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER3]
11636     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11637   pushdecl (build_decl (TYPE_DECL, get_identifier ("word"),
11638                         t));
11639   type = ffetype_new ();
11640   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER3,
11641                     type);
11642   ffetype_set_ams (type,
11643                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11644                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11645   ffetype_set_star (base_type,
11646                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11647                     type);
11648   ffetype_set_kind (base_type, 6, type);
11649   assert (ffetype_size (type) == sizeof (ffetargetInteger3));
11650
11651   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER3]
11652     = t = make_unsigned_type (CHAR_TYPE_SIZE * 2);
11653   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned word"),
11654                         t));
11655
11656   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER4]
11657     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11658   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer4"),
11659                         t));
11660   type = ffetype_new ();
11661   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER4,
11662                     type);
11663   ffetype_set_ams (type,
11664                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11665                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11666   ffetype_set_star (base_type,
11667                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11668                     type);
11669   ffetype_set_kind (base_type, 2, type);
11670   assert (ffetype_size (type) == sizeof (ffetargetInteger4));
11671
11672   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER4]
11673     = t = make_unsigned_type (FLOAT_TYPE_SIZE * 2);
11674   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned4"),
11675                         t));
11676
11677 #if 0
11678   if (ffe_is_do_internal_checks ()
11679       && LONG_TYPE_SIZE != FLOAT_TYPE_SIZE
11680       && LONG_TYPE_SIZE != CHAR_TYPE_SIZE
11681       && LONG_TYPE_SIZE != SHORT_TYPE_SIZE
11682       && LONG_TYPE_SIZE != LONG_LONG_TYPE_SIZE)
11683     {
11684       fprintf (stderr, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n",
11685                LONG_TYPE_SIZE);
11686     }
11687 #endif
11688
11689   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL1]
11690     = t = make_signed_type (FLOAT_TYPE_SIZE);
11691   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical"),
11692                         t));
11693   type = ffetype_new ();
11694   base_type = type;
11695   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL1,
11696                     type);
11697   ffetype_set_ams (type,
11698                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11699                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11700   ffetype_set_star (base_type,
11701                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11702                     type);
11703   ffetype_set_kind (base_type, 1, type);
11704   assert (ffetype_size (type) == sizeof (ffetargetLogical1));
11705
11706   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL2]
11707     = t = make_signed_type (CHAR_TYPE_SIZE);
11708   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical2"),
11709                         t));
11710   type = ffetype_new ();
11711   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL2,
11712                     type);
11713   ffetype_set_ams (type,
11714                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11715                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11716   ffetype_set_star (base_type,
11717                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11718                     type);
11719   ffetype_set_kind (base_type, 3, type);
11720   assert (ffetype_size (type) == sizeof (ffetargetLogical2));
11721
11722   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL3]
11723     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11724   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical3"),
11725                         t));
11726   type = ffetype_new ();
11727   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL3,
11728                     type);
11729   ffetype_set_ams (type,
11730                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11731                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11732   ffetype_set_star (base_type,
11733                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11734                     type);
11735   ffetype_set_kind (base_type, 6, type);
11736   assert (ffetype_size (type) == sizeof (ffetargetLogical3));
11737
11738   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL4]
11739     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11740   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical4"),
11741                         t));
11742   type = ffetype_new ();
11743   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL4,
11744                     type);
11745   ffetype_set_ams (type,
11746                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11747                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11748   ffetype_set_star (base_type,
11749                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11750                     type);
11751   ffetype_set_kind (base_type, 2, type);
11752   assert (ffetype_size (type) == sizeof (ffetargetLogical4));
11753
11754   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11755     = t = make_node (REAL_TYPE);
11756   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE;
11757   pushdecl (build_decl (TYPE_DECL, get_identifier ("real"),
11758                         t));
11759   layout_type (t);
11760   type = ffetype_new ();
11761   base_type = type;
11762   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL1,
11763                     type);
11764   ffetype_set_ams (type,
11765                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11766                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11767   ffetype_set_star (base_type,
11768                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11769                     type);
11770   ffetype_set_kind (base_type, 1, type);
11771   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11772     = FFETARGET_f2cTYREAL;
11773   assert (ffetype_size (type) == sizeof (ffetargetReal1));
11774
11775   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREALDOUBLE]
11776     = t = make_node (REAL_TYPE);
11777   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE * 2;     /* Always twice REAL. */
11778   pushdecl (build_decl (TYPE_DECL, get_identifier ("double precision"),
11779                         t));
11780   layout_type (t);
11781   type = ffetype_new ();
11782   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
11783                     type);
11784   ffetype_set_ams (type,
11785                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11786                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11787   ffetype_set_star (base_type,
11788                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11789                     type);
11790   ffetype_set_kind (base_type, 2, type);
11791   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]
11792     = FFETARGET_f2cTYDREAL;
11793   assert (ffetype_size (type) == sizeof (ffetargetReal2));
11794
11795   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11796     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]);
11797   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex"),
11798                         t));
11799   type = ffetype_new ();
11800   base_type = type;
11801   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL1,
11802                     type);
11803   ffetype_set_ams (type,
11804                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11805                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11806   ffetype_set_star (base_type,
11807                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11808                     type);
11809   ffetype_set_kind (base_type, 1, type);
11810   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11811     = FFETARGET_f2cTYCOMPLEX;
11812   assert (ffetype_size (type) == sizeof (ffetargetComplex1));
11813
11814   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREALDOUBLE]
11815     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]);
11816   pushdecl (build_decl (TYPE_DECL, get_identifier ("double complex"),
11817                         t));
11818   type = ffetype_new ();
11819   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREALDOUBLE,
11820                     type);
11821   ffetype_set_ams (type,
11822                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11823                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11824   ffetype_set_star (base_type,
11825                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11826                     type);
11827   ffetype_set_kind (base_type, 2,
11828                     type);
11829   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL2]
11830     = FFETARGET_f2cTYDCOMPLEX;
11831   assert (ffetype_size (type) == sizeof (ffetargetComplex2));
11832
11833   /* Make function and ptr-to-function types for non-CHARACTER types. */
11834
11835   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11836     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11837       {
11838         if ((t = ffecom_tree_type[i][j]) != NULL_TREE)
11839           {
11840             if (i == FFEINFO_basictypeINTEGER)
11841               {
11842                 /* Figure out the smallest INTEGER type that can hold
11843                    a pointer on this machine. */
11844                 if (GET_MODE_SIZE (TYPE_MODE (t))
11845                     >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
11846                   {
11847                     if ((ffecom_pointer_kind_ == FFEINFO_kindtypeNONE)
11848                         || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type[i][ffecom_pointer_kind_]))
11849                             > GET_MODE_SIZE (TYPE_MODE (t))))
11850                       ffecom_pointer_kind_ = j;
11851                   }
11852               }
11853             else if (i == FFEINFO_basictypeCOMPLEX)
11854               t = void_type_node;
11855             /* For f2c compatibility, REAL functions are really
11856                implemented as DOUBLE PRECISION.  */
11857             else if ((i == FFEINFO_basictypeREAL)
11858                      && (j == FFEINFO_kindtypeREAL1))
11859               t = ffecom_tree_type
11860                 [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2];
11861
11862             t = ffecom_tree_fun_type[i][j] = build_function_type (t,
11863                                                                   NULL_TREE);
11864             ffecom_tree_ptr_to_fun_type[i][j] = build_pointer_type (t);
11865           }
11866       }
11867
11868   /* Set up pointer types.  */
11869
11870   if (ffecom_pointer_kind_ == FFEINFO_basictypeNONE)
11871     fatal ("no INTEGER type can hold a pointer on this configuration");
11872   else if (0 && ffe_is_do_internal_checks ())
11873     fprintf (stderr, "Pointer type kt=%d\n", ffecom_pointer_kind_);
11874   ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER,
11875                                   FFEINFO_kindtypeINTEGERDEFAULT),
11876                     7,
11877                     ffeinfo_type (FFEINFO_basictypeINTEGER,
11878                                   ffecom_pointer_kind_));
11879
11880   if (ffe_is_ugly_assign ())
11881     ffecom_label_kind_ = ffecom_pointer_kind_;  /* Require ASSIGN etc to this. */
11882   else
11883     ffecom_label_kind_ = FFEINFO_kindtypeINTEGERDEFAULT;
11884   if (0 && ffe_is_do_internal_checks ())
11885     fprintf (stderr, "Label type kt=%d\n", ffecom_label_kind_);
11886
11887   ffecom_integer_type_node
11888     = ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1];
11889   ffecom_integer_zero_node = convert (ffecom_integer_type_node,
11890                                       integer_zero_node);
11891   ffecom_integer_one_node = convert (ffecom_integer_type_node,
11892                                      integer_one_node);
11893
11894   /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
11895      Turns out that by TYLONG, runtime/libI77/lio.h really means
11896      "whatever size an ftnint is".  For consistency and sanity,
11897      com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
11898      all are INTEGER, which we also make out of whatever back-end
11899      integer type is FLOAT_TYPE_SIZE bits wide.  This change, from
11900      LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
11901      accommodate machines like the Alpha.  Note that this suggests
11902      f2c and libf2c are missing a distinction perhaps needed on
11903      some machines between "int" and "long int".  -- burley 0.5.5 950215 */
11904
11905   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, FLOAT_TYPE_SIZE,
11906                             FFETARGET_f2cTYLONG);
11907   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, SHORT_TYPE_SIZE,
11908                             FFETARGET_f2cTYSHORT);
11909   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, CHAR_TYPE_SIZE,
11910                             FFETARGET_f2cTYINT1);
11911   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, LONG_LONG_TYPE_SIZE,
11912                             FFETARGET_f2cTYQUAD);
11913   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, FLOAT_TYPE_SIZE,
11914                             FFETARGET_f2cTYLOGICAL);
11915   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, SHORT_TYPE_SIZE,
11916                             FFETARGET_f2cTYLOGICAL2);
11917   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, CHAR_TYPE_SIZE,
11918                             FFETARGET_f2cTYLOGICAL1);
11919   /* ~~~Not really such a type in libf2c, e.g. I/O support?  */
11920   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, LONG_LONG_TYPE_SIZE,
11921                             FFETARGET_f2cTYQUAD);
11922
11923   /* CHARACTER stuff is all special-cased, so it is not handled in the above
11924      loop.  CHARACTER items are built as arrays of unsigned char.  */
11925
11926   ffecom_tree_type[FFEINFO_basictypeCHARACTER]
11927     [FFEINFO_kindtypeCHARACTER1] = t = char_type_node;
11928   type = ffetype_new ();
11929   base_type = type;
11930   ffeinfo_set_type (FFEINFO_basictypeCHARACTER,
11931                     FFEINFO_kindtypeCHARACTER1,
11932                     type);
11933   ffetype_set_ams (type,
11934                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11935                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11936   ffetype_set_kind (base_type, 1, type);
11937   assert (ffetype_size (type)
11938           == sizeof (((ffetargetCharacter1) { 0, NULL }).text[0]));
11939
11940   ffecom_tree_fun_type[FFEINFO_basictypeCHARACTER]
11941     [FFEINFO_kindtypeCHARACTER1] = ffecom_tree_fun_type_void;
11942   ffecom_tree_ptr_to_fun_type[FFEINFO_basictypeCHARACTER]
11943     [FFEINFO_kindtypeCHARACTER1]
11944     = ffecom_tree_ptr_to_fun_type_void;
11945   ffecom_f2c_typecode_[FFEINFO_basictypeCHARACTER][FFEINFO_kindtypeCHARACTER1]
11946     = FFETARGET_f2cTYCHAR;
11947
11948   ffecom_f2c_typecode_[FFEINFO_basictypeANY][FFEINFO_kindtypeANY]
11949     = 0;
11950
11951   /* Make multi-return-value type and fields. */
11952
11953   ffecom_multi_type_node_ = make_node (UNION_TYPE);
11954
11955   field = NULL_TREE;
11956
11957   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11958     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11959       {
11960         char name[30];
11961
11962         if (ffecom_tree_type[i][j] == NULL_TREE)
11963           continue;             /* Not supported. */
11964         sprintf (&name[0], "bt_%s_kt_%s",
11965                  ffeinfo_basictype_string ((ffeinfoBasictype) i),
11966                  ffeinfo_kindtype_string ((ffeinfoKindtype) j));
11967         ffecom_multi_fields_[i][j] = build_decl (FIELD_DECL,
11968                                                  get_identifier (name),
11969                                                  ffecom_tree_type[i][j]);
11970         DECL_CONTEXT (ffecom_multi_fields_[i][j])
11971           = ffecom_multi_type_node_;
11972         DECL_ALIGN (ffecom_multi_fields_[i][j]) = 0;
11973         DECL_USER_ALIGN (ffecom_multi_fields_[i][j]) = 0;
11974         TREE_CHAIN (ffecom_multi_fields_[i][j]) = field;
11975         field = ffecom_multi_fields_[i][j];
11976       }
11977
11978   TYPE_FIELDS (ffecom_multi_type_node_) = field;
11979   layout_type (ffecom_multi_type_node_);
11980
11981   /* Subroutines usually return integer because they might have alternate
11982      returns. */
11983
11984   ffecom_tree_subr_type
11985     = build_function_type (integer_type_node, NULL_TREE);
11986   ffecom_tree_ptr_to_subr_type
11987     = build_pointer_type (ffecom_tree_subr_type);
11988   ffecom_tree_blockdata_type
11989     = build_function_type (void_type_node, NULL_TREE);
11990
11991   builtin_function ("__builtin_sqrtf", float_ftype_float,
11992                     BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrtf");
11993   builtin_function ("__builtin_fsqrt", double_ftype_double,
11994                     BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrt");
11995   builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble,
11996                     BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrtl");
11997   builtin_function ("__builtin_sinf", float_ftype_float,
11998                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sinf");
11999   builtin_function ("__builtin_sin", double_ftype_double,
12000                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sin");
12001   builtin_function ("__builtin_sinl", ldouble_ftype_ldouble,
12002                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sinl");
12003   builtin_function ("__builtin_cosf", float_ftype_float,
12004                     BUILT_IN_COS, BUILT_IN_NORMAL, "cosf");
12005   builtin_function ("__builtin_cos", double_ftype_double,
12006                     BUILT_IN_COS, BUILT_IN_NORMAL, "cos");
12007   builtin_function ("__builtin_cosl", ldouble_ftype_ldouble,
12008                     BUILT_IN_COS, BUILT_IN_NORMAL, "cosl");
12009
12010 #if BUILT_FOR_270
12011   pedantic_lvalues = FALSE;
12012 #endif
12013
12014   ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node,
12015                          FFECOM_f2cINTEGER,
12016                          "integer");
12017   ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node,
12018                          FFECOM_f2cADDRESS,
12019                          "address");
12020   ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node,
12021                          FFECOM_f2cREAL,
12022                          "real");
12023   ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node,
12024                          FFECOM_f2cDOUBLEREAL,
12025                          "doublereal");
12026   ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node,
12027                          FFECOM_f2cCOMPLEX,
12028                          "complex");
12029   ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node,
12030                          FFECOM_f2cDOUBLECOMPLEX,
12031                          "doublecomplex");
12032   ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node,
12033                          FFECOM_f2cLONGINT,
12034                          "longint");
12035   ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node,
12036                          FFECOM_f2cLOGICAL,
12037                          "logical");
12038   ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node,
12039                          FFECOM_f2cFLAG,
12040                          "flag");
12041   ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node,
12042                          FFECOM_f2cFTNLEN,
12043                          "ftnlen");
12044   ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node,
12045                          FFECOM_f2cFTNINT,
12046                          "ftnint");
12047
12048   ffecom_f2c_ftnlen_zero_node
12049     = convert (ffecom_f2c_ftnlen_type_node, integer_zero_node);
12050
12051   ffecom_f2c_ftnlen_one_node
12052     = convert (ffecom_f2c_ftnlen_type_node, integer_one_node);
12053
12054   ffecom_f2c_ftnlen_two_node = build_int_2 (2, 0);
12055   TREE_TYPE (ffecom_f2c_ftnlen_two_node) = ffecom_integer_type_node;
12056
12057   ffecom_f2c_ptr_to_ftnlen_type_node
12058     = build_pointer_type (ffecom_f2c_ftnlen_type_node);
12059
12060   ffecom_f2c_ptr_to_ftnint_type_node
12061     = build_pointer_type (ffecom_f2c_ftnint_type_node);
12062
12063   ffecom_f2c_ptr_to_integer_type_node
12064     = build_pointer_type (ffecom_f2c_integer_type_node);
12065
12066   ffecom_f2c_ptr_to_real_type_node
12067     = build_pointer_type (ffecom_f2c_real_type_node);
12068
12069   ffecom_float_zero_ = build_real (float_type_node, dconst0);
12070   ffecom_double_zero_ = build_real (double_type_node, dconst0);
12071   {
12072     REAL_VALUE_TYPE point_5;
12073
12074 #ifdef REAL_ARITHMETIC
12075     REAL_ARITHMETIC (point_5, RDIV_EXPR, dconst1, dconst2);
12076 #else
12077     point_5 = .5;
12078 #endif
12079     ffecom_float_half_ = build_real (float_type_node, point_5);
12080     ffecom_double_half_ = build_real (double_type_node, point_5);
12081   }
12082
12083   /* Do "extern int xargc;".  */
12084
12085   ffecom_tree_xargc_ = build_decl (VAR_DECL,
12086                                    get_identifier ("f__xargc"),
12087                                    integer_type_node);
12088   DECL_EXTERNAL (ffecom_tree_xargc_) = 1;
12089   TREE_STATIC (ffecom_tree_xargc_) = 1;
12090   TREE_PUBLIC (ffecom_tree_xargc_) = 1;
12091   ffecom_tree_xargc_ = start_decl (ffecom_tree_xargc_, FALSE);
12092   finish_decl (ffecom_tree_xargc_, NULL_TREE, FALSE);
12093
12094 #if 0   /* This is being fixed, and seems to be working now. */
12095   if ((FLOAT_TYPE_SIZE != 32)
12096       || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))) != 32))
12097     {
12098       warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,",
12099                (int) FLOAT_TYPE_SIZE);
12100       warning ("and pointers are %d bits wide, but g77 doesn't yet work",
12101           (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))));
12102       warning ("properly unless they all are 32 bits wide.");
12103       warning ("Please keep this in mind before you report bugs.  g77 should");
12104       warning ("support non-32-bit machines better as of version 0.6.");
12105     }
12106 #endif
12107
12108 #if 0   /* Code in ste.c that would crash has been commented out. */
12109   if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
12110       < TYPE_PRECISION (string_type_node))
12111     /* I/O will probably crash.  */
12112     warning ("configuration: char * holds %d bits, but ftnlen only %d",
12113              TYPE_PRECISION (string_type_node),
12114              TYPE_PRECISION (ffecom_f2c_ftnlen_type_node));
12115 #endif
12116
12117 #if 0   /* ASSIGN-related stuff has been changed to accommodate this. */
12118   if (TYPE_PRECISION (ffecom_integer_type_node)
12119       < TYPE_PRECISION (string_type_node))
12120     /* ASSIGN 10 TO I will crash.  */
12121     warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
12122  ASSIGN statement might fail",
12123              TYPE_PRECISION (string_type_node),
12124              TYPE_PRECISION (ffecom_integer_type_node));
12125 #endif
12126 }
12127
12128 #endif
12129 /* ffecom_init_2 -- Initialize
12130
12131    ffecom_init_2();  */
12132
12133 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12134 void
12135 ffecom_init_2 ()
12136 {
12137   assert (ffecom_outer_function_decl_ == NULL_TREE);
12138   assert (current_function_decl == NULL_TREE);
12139   assert (ffecom_which_entrypoint_decl_ == NULL_TREE);
12140
12141   ffecom_master_arglist_ = NULL;
12142   ++ffecom_num_fns_;
12143   ffecom_primary_entry_ = NULL;
12144   ffecom_is_altreturning_ = FALSE;
12145   ffecom_func_result_ = NULL_TREE;
12146   ffecom_multi_retval_ = NULL_TREE;
12147 }
12148
12149 #endif
12150 /* ffecom_list_expr -- Transform list of exprs into gcc tree
12151
12152    tree t;
12153    ffebld expr;  // FFE opITEM list.
12154    tree = ffecom_list_expr(expr);
12155
12156    List of actual args is transformed into corresponding gcc backend list.  */
12157
12158 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12159 tree
12160 ffecom_list_expr (ffebld expr)
12161 {
12162   tree list;
12163   tree *plist = &list;
12164   tree trail = NULL_TREE;       /* Append char length args here. */
12165   tree *ptrail = &trail;
12166   tree length;
12167
12168   while (expr != NULL)
12169     {
12170       tree texpr = ffecom_arg_expr (ffebld_head (expr), &length);
12171
12172       if (texpr == error_mark_node)
12173         return error_mark_node;
12174
12175       *plist = build_tree_list (NULL_TREE, texpr);
12176       plist = &TREE_CHAIN (*plist);
12177       expr = ffebld_trail (expr);
12178       if (length != NULL_TREE)
12179         {
12180           *ptrail = build_tree_list (NULL_TREE, length);
12181           ptrail = &TREE_CHAIN (*ptrail);
12182         }
12183     }
12184
12185   *plist = trail;
12186
12187   return list;
12188 }
12189
12190 #endif
12191 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
12192
12193    tree t;
12194    ffebld expr;  // FFE opITEM list.
12195    tree = ffecom_list_ptr_to_expr(expr);
12196
12197    List of actual args is transformed into corresponding gcc backend list for
12198    use in calling an external procedure (vs. a statement function).  */
12199
12200 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12201 tree
12202 ffecom_list_ptr_to_expr (ffebld expr)
12203 {
12204   tree list;
12205   tree *plist = &list;
12206   tree trail = NULL_TREE;       /* Append char length args here. */
12207   tree *ptrail = &trail;
12208   tree length;
12209
12210   while (expr != NULL)
12211     {
12212       tree texpr = ffecom_arg_ptr_to_expr (ffebld_head (expr), &length);
12213
12214       if (texpr == error_mark_node)
12215         return error_mark_node;
12216
12217       *plist = build_tree_list (NULL_TREE, texpr);
12218       plist = &TREE_CHAIN (*plist);
12219       expr = ffebld_trail (expr);
12220       if (length != NULL_TREE)
12221         {
12222           *ptrail = build_tree_list (NULL_TREE, length);
12223           ptrail = &TREE_CHAIN (*ptrail);
12224         }
12225     }
12226
12227   *plist = trail;
12228
12229   return list;
12230 }
12231
12232 #endif
12233 /* Obtain gcc's LABEL_DECL tree for label.  */
12234
12235 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12236 tree
12237 ffecom_lookup_label (ffelab label)
12238 {
12239   tree glabel;
12240
12241   if (ffelab_hook (label) == NULL_TREE)
12242     {
12243       char labelname[16];
12244
12245       switch (ffelab_type (label))
12246         {
12247         case FFELAB_typeLOOPEND:
12248         case FFELAB_typeNOTLOOP:
12249         case FFELAB_typeENDIF:
12250           sprintf (labelname, "%" ffelabValue_f "u", ffelab_value (label));
12251           glabel = build_decl (LABEL_DECL, get_identifier (labelname),
12252                                void_type_node);
12253           DECL_CONTEXT (glabel) = current_function_decl;
12254           DECL_MODE (glabel) = VOIDmode;
12255           break;
12256
12257         case FFELAB_typeFORMAT:
12258           glabel = build_decl (VAR_DECL,
12259                                ffecom_get_invented_identifier
12260                                ("__g77_format_%d", (int) ffelab_value (label)),
12261                                build_type_variant (build_array_type
12262                                                    (char_type_node,
12263                                                     NULL_TREE),
12264                                                    1, 0));
12265           TREE_CONSTANT (glabel) = 1;
12266           TREE_STATIC (glabel) = 1;
12267           DECL_CONTEXT (glabel) = 0;
12268           DECL_INITIAL (glabel) = NULL;
12269           make_decl_rtl (glabel, NULL, 0);
12270           expand_decl (glabel);
12271
12272           ffecom_save_tree_forever (glabel);
12273
12274           break;
12275
12276         case FFELAB_typeANY:
12277           glabel = error_mark_node;
12278           break;
12279
12280         default:
12281           assert ("bad label type" == NULL);
12282           glabel = NULL;
12283           break;
12284         }
12285       ffelab_set_hook (label, glabel);
12286     }
12287   else
12288     {
12289       glabel = ffelab_hook (label);
12290     }
12291
12292   return glabel;
12293 }
12294
12295 #endif
12296 /* Stabilizes the arguments.  Don't use this if the lhs and rhs come from
12297    a single source specification (as in the fourth argument of MVBITS).
12298    If the type is NULL_TREE, the type of lhs is used to make the type of
12299    the MODIFY_EXPR.  */
12300
12301 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12302 tree
12303 ffecom_modify (tree newtype, tree lhs,
12304                tree rhs)
12305 {
12306   if (lhs == error_mark_node || rhs == error_mark_node)
12307     return error_mark_node;
12308
12309   if (newtype == NULL_TREE)
12310     newtype = TREE_TYPE (lhs);
12311
12312   if (TREE_SIDE_EFFECTS (lhs))
12313     lhs = stabilize_reference (lhs);
12314
12315   return ffecom_2s (MODIFY_EXPR, newtype, lhs, rhs);
12316 }
12317
12318 #endif
12319
12320 /* Register source file name.  */
12321
12322 void
12323 ffecom_file (const char *name)
12324 {
12325 #if FFECOM_GCC_INCLUDE
12326   ffecom_file_ (name);
12327 #endif
12328 }
12329
12330 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
12331
12332    ffestorag st;
12333    ffecom_notify_init_storage(st);
12334
12335    Gets called when all possible units in an aggregate storage area (a LOCAL
12336    with equivalences or a COMMON) have been initialized.  The initialization
12337    info either is in ffestorag_init or, if that is NULL,
12338    ffestorag_accretion:
12339
12340    ffestorag_init may contain an opCONTER or opARRTER.  opCONTER may occur
12341    even for an array if the array is one element in length!
12342
12343    ffestorag_accretion will contain an opACCTER.  It is much like an
12344    opARRTER except it has an ffebit object in it instead of just a size.
12345    The back end can use the info in the ffebit object, if it wants, to
12346    reduce the amount of actual initialization, but in any case it should
12347    kill the ffebit object when done.  Also, set accretion to NULL but
12348    init to a non-NULL value.
12349
12350    After performing initialization, DO NOT set init to NULL, because that'll
12351    tell the front end it is ok for more initialization to happen.  Instead,
12352    set init to an opANY expression or some such thing that you can use to
12353    tell that you've already initialized the object.
12354
12355    27-Oct-91  JCB  1.1
12356       Support two-pass FFE.  */
12357
12358 void
12359 ffecom_notify_init_storage (ffestorag st)
12360 {
12361   ffebld init;                  /* The initialization expression. */
12362 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12363   ffetargetOffset size;         /* The size of the entity. */
12364   ffetargetAlign pad;           /* Its initial padding. */
12365 #endif
12366
12367   if (ffestorag_init (st) == NULL)
12368     {
12369       init = ffestorag_accretion (st);
12370       assert (init != NULL);
12371       ffestorag_set_accretion (st, NULL);
12372       ffestorag_set_accretes (st, 0);
12373
12374 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12375       /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12376       size = ffebld_accter_size (init);
12377       pad = ffebld_accter_pad (init);
12378       ffebit_kill (ffebld_accter_bits (init));
12379       ffebld_set_op (init, FFEBLD_opARRTER);
12380       ffebld_set_arrter (init, ffebld_accter (init));
12381       ffebld_arrter_set_size (init, size);
12382       ffebld_arrter_set_pad (init, size);
12383 #endif
12384
12385 #if FFECOM_TWOPASS
12386       ffestorag_set_init (st, init);
12387 #endif
12388     }
12389 #if FFECOM_ONEPASS
12390   else
12391     init = ffestorag_init (st);
12392 #endif
12393
12394 #if FFECOM_ONEPASS              /* Process the inits, wipe 'em out. */
12395   ffestorag_set_init (st, ffebld_new_any ());
12396
12397   if (ffebld_op (init) == FFEBLD_opANY)
12398     return;                     /* Oh, we already did this! */
12399
12400 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12401   {
12402     ffesymbol s;
12403
12404     if (ffestorag_symbol (st) != NULL)
12405       s = ffestorag_symbol (st);
12406     else
12407       s = ffestorag_typesymbol (st);
12408
12409     fprintf (dmpout, "= initialize_storage \"%s\" ",
12410              (s != NULL) ? ffesymbol_text (s) : "(unnamed)");
12411     ffebld_dump (init);
12412     fputc ('\n', dmpout);
12413   }
12414 #endif
12415
12416 #endif /* if FFECOM_ONEPASS */
12417 }
12418
12419 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12420
12421    ffesymbol s;
12422    ffecom_notify_init_symbol(s);
12423
12424    Gets called when all possible units in a symbol (not placed in COMMON
12425    or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12426    have been initialized.  The initialization info either is in
12427    ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12428
12429    ffesymbol_init may contain an opCONTER or opARRTER.  opCONTER may occur
12430    even for an array if the array is one element in length!
12431
12432    ffesymbol_accretion will contain an opACCTER.  It is much like an
12433    opARRTER except it has an ffebit object in it instead of just a size.
12434    The back end can use the info in the ffebit object, if it wants, to
12435    reduce the amount of actual initialization, but in any case it should
12436    kill the ffebit object when done.  Also, set accretion to NULL but
12437    init to a non-NULL value.
12438
12439    After performing initialization, DO NOT set init to NULL, because that'll
12440    tell the front end it is ok for more initialization to happen.  Instead,
12441    set init to an opANY expression or some such thing that you can use to
12442    tell that you've already initialized the object.
12443
12444    27-Oct-91  JCB  1.1
12445       Support two-pass FFE.  */
12446
12447 void
12448 ffecom_notify_init_symbol (ffesymbol s)
12449 {
12450   ffebld init;                  /* The initialization expression. */
12451 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12452   ffetargetOffset size;         /* The size of the entity. */
12453   ffetargetAlign pad;           /* Its initial padding. */
12454 #endif
12455
12456   if (ffesymbol_storage (s) == NULL)
12457     return;                     /* Do nothing until COMMON/EQUIVALENCE
12458                                    possibilities checked. */
12459
12460   if ((ffesymbol_init (s) == NULL)
12461       && ((init = ffesymbol_accretion (s)) != NULL))
12462     {
12463       ffesymbol_set_accretion (s, NULL);
12464       ffesymbol_set_accretes (s, 0);
12465
12466 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12467       /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12468       size = ffebld_accter_size (init);
12469       pad = ffebld_accter_pad (init);
12470       ffebit_kill (ffebld_accter_bits (init));
12471       ffebld_set_op (init, FFEBLD_opARRTER);
12472       ffebld_set_arrter (init, ffebld_accter (init));
12473       ffebld_arrter_set_size (init, size);
12474       ffebld_arrter_set_pad (init, size);
12475 #endif
12476
12477 #if FFECOM_TWOPASS
12478       ffesymbol_set_init (s, init);
12479 #endif
12480     }
12481 #if FFECOM_ONEPASS
12482   else
12483     init = ffesymbol_init (s);
12484 #endif
12485
12486 #if FFECOM_ONEPASS
12487   ffesymbol_set_init (s, ffebld_new_any ());
12488
12489   if (ffebld_op (init) == FFEBLD_opANY)
12490     return;                     /* Oh, we already did this! */
12491
12492 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12493   fprintf (dmpout, "= initialize_symbol \"%s\" ", ffesymbol_text (s));
12494   ffebld_dump (init);
12495   fputc ('\n', dmpout);
12496 #endif
12497
12498 #endif /* if FFECOM_ONEPASS */
12499 }
12500
12501 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12502
12503    ffesymbol s;
12504    ffecom_notify_primary_entry(s);
12505
12506    Gets called when implicit or explicit PROGRAM statement seen or when
12507    FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12508    global symbol that serves as the entry point.  */
12509
12510 void
12511 ffecom_notify_primary_entry (ffesymbol s)
12512 {
12513   ffecom_primary_entry_ = s;
12514   ffecom_primary_entry_kind_ = ffesymbol_kind (s);
12515
12516   if ((ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
12517       || (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE))
12518     ffecom_primary_entry_is_proc_ = TRUE;
12519   else
12520     ffecom_primary_entry_is_proc_ = FALSE;
12521
12522   if (!ffe_is_silent ())
12523     {
12524       if (ffecom_primary_entry_kind_ == FFEINFO_kindPROGRAM)
12525         fprintf (stderr, "%s:\n", ffesymbol_text (s));
12526       else
12527         fprintf (stderr, "  %s:\n", ffesymbol_text (s));
12528     }
12529
12530 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12531   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
12532     {
12533       ffebld list;
12534       ffebld arg;
12535
12536       for (list = ffesymbol_dummyargs (s);
12537            list != NULL;
12538            list = ffebld_trail (list))
12539         {
12540           arg = ffebld_head (list);
12541           if (ffebld_op (arg) == FFEBLD_opSTAR)
12542             {
12543               ffecom_is_altreturning_ = TRUE;
12544               break;
12545             }
12546         }
12547     }
12548 #endif
12549 }
12550
12551 FILE *
12552 ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c)
12553 {
12554 #if FFECOM_GCC_INCLUDE
12555   return ffecom_open_include_ (name, l, c);
12556 #else
12557   return fopen (name, "r");
12558 #endif
12559 }
12560
12561 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
12562
12563    tree t;
12564    ffebld expr;  // FFE expression.
12565    tree = ffecom_ptr_to_expr(expr);
12566
12567    Like ffecom_expr, but sticks address-of in front of most things.  */
12568
12569 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12570 tree
12571 ffecom_ptr_to_expr (ffebld expr)
12572 {
12573   tree item;
12574   ffeinfoBasictype bt;
12575   ffeinfoKindtype kt;
12576   ffesymbol s;
12577
12578   assert (expr != NULL);
12579
12580   switch (ffebld_op (expr))
12581     {
12582     case FFEBLD_opSYMTER:
12583       s = ffebld_symter (expr);
12584       if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
12585         {
12586           ffecomGfrt ix;
12587
12588           ix = ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr));
12589           assert (ix != FFECOM_gfrt);
12590           if ((item = ffecom_gfrt_[ix]) == NULL_TREE)
12591             {
12592               ffecom_make_gfrt_ (ix);
12593               item = ffecom_gfrt_[ix];
12594             }
12595         }
12596       else
12597         {
12598           item = ffesymbol_hook (s).decl_tree;
12599           if (item == NULL_TREE)
12600             {
12601               s = ffecom_sym_transform_ (s);
12602               item = ffesymbol_hook (s).decl_tree;
12603             }
12604         }
12605       assert (item != NULL);
12606       if (item == error_mark_node)
12607         return item;
12608       if (!ffesymbol_hook (s).addr)
12609         item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12610                          item);
12611       return item;
12612
12613     case FFEBLD_opARRAYREF:
12614       return ffecom_arrayref_ (NULL_TREE, expr, 1);
12615
12616     case FFEBLD_opCONTER:
12617
12618       bt = ffeinfo_basictype (ffebld_info (expr));
12619       kt = ffeinfo_kindtype (ffebld_info (expr));
12620
12621       item = ffecom_constantunion (&ffebld_constant_union
12622                                    (ffebld_conter (expr)), bt, kt,
12623                                    ffecom_tree_type[bt][kt]);
12624       if (item == error_mark_node)
12625         return error_mark_node;
12626       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12627                        item);
12628       return item;
12629
12630     case FFEBLD_opANY:
12631       return error_mark_node;
12632
12633     default:
12634       bt = ffeinfo_basictype (ffebld_info (expr));
12635       kt = ffeinfo_kindtype (ffebld_info (expr));
12636
12637       item = ffecom_expr (expr);
12638       if (item == error_mark_node)
12639         return error_mark_node;
12640
12641       /* The back end currently optimizes a bit too zealously for us, in that
12642          we fail JCB001 if the following block of code is omitted.  It checks
12643          to see if the transformed expression is a symbol or array reference,
12644          and encloses it in a SAVE_EXPR if that is the case.  */
12645
12646       STRIP_NOPS (item);
12647       if ((TREE_CODE (item) == VAR_DECL)
12648           || (TREE_CODE (item) == PARM_DECL)
12649           || (TREE_CODE (item) == RESULT_DECL)
12650           || (TREE_CODE (item) == INDIRECT_REF)
12651           || (TREE_CODE (item) == ARRAY_REF)
12652           || (TREE_CODE (item) == COMPONENT_REF)
12653 #ifdef OFFSET_REF
12654           || (TREE_CODE (item) == OFFSET_REF)
12655 #endif
12656           || (TREE_CODE (item) == BUFFER_REF)
12657           || (TREE_CODE (item) == REALPART_EXPR)
12658           || (TREE_CODE (item) == IMAGPART_EXPR))
12659         {
12660           item = ffecom_save_tree (item);
12661         }
12662
12663       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12664                        item);
12665       return item;
12666     }
12667
12668   assert ("fall-through error" == NULL);
12669   return error_mark_node;
12670 }
12671
12672 #endif
12673 /* Obtain a temp var with given data type.
12674
12675    size is FFETARGET_charactersizeNONE for a non-CHARACTER type
12676    or >= 0 for a CHARACTER type.
12677
12678    elements is -1 for a scalar or > 0 for an array of type.  */
12679
12680 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12681 tree
12682 ffecom_make_tempvar (const char *commentary, tree type,
12683                      ffetargetCharacterSize size, int elements)
12684 {
12685   tree t;
12686   static int mynumber;
12687
12688   assert (current_binding_level->prep_state < 2);
12689
12690   if (type == error_mark_node)
12691     return error_mark_node;
12692
12693   if (size != FFETARGET_charactersizeNONE)
12694     type = build_array_type (type,
12695                              build_range_type (ffecom_f2c_ftnlen_type_node,
12696                                                ffecom_f2c_ftnlen_one_node,
12697                                                build_int_2 (size, 0)));
12698   if (elements != -1)
12699     type = build_array_type (type,
12700                              build_range_type (integer_type_node,
12701                                                integer_zero_node,
12702                                                build_int_2 (elements - 1,
12703                                                             0)));
12704   t = build_decl (VAR_DECL,
12705                   ffecom_get_invented_identifier ("__g77_%s_%d",
12706                                                   commentary,
12707                                                   mynumber++),
12708                   type);
12709
12710   t = start_decl (t, FALSE);
12711   finish_decl (t, NULL_TREE, FALSE);
12712
12713   return t;
12714 }
12715 #endif
12716
12717 /* Prepare argument pointer to expression.
12718
12719    Like ffecom_prepare_expr, except for expressions to be evaluated
12720    via ffecom_arg_ptr_to_expr.  */
12721
12722 void
12723 ffecom_prepare_arg_ptr_to_expr (ffebld expr)
12724 {
12725   /* ~~For now, it seems to be the same thing.  */
12726   ffecom_prepare_expr (expr);
12727   return;
12728 }
12729
12730 /* End of preparations.  */
12731
12732 bool
12733 ffecom_prepare_end (void)
12734 {
12735   int prep_state = current_binding_level->prep_state;
12736
12737   assert (prep_state < 2);
12738   current_binding_level->prep_state = 2;
12739
12740   return (prep_state == 1) ? TRUE : FALSE;
12741 }
12742
12743 /* Prepare expression.
12744
12745    This is called before any code is generated for the current block.
12746    It scans the expression, declares any temporaries that might be needed
12747    during evaluation of the expression, and stores those temporaries in
12748    the appropriate "hook" fields of the expression.  `dest', if not NULL,
12749    specifies the destination that ffecom_expr_ will see, in case that
12750    helps avoid generating unused temporaries.
12751
12752    ~~Improve to avoid allocating unused temporaries by taking `dest'
12753    into account vis-a-vis aliasing requirements of complex/character
12754    functions.  */
12755
12756 void
12757 ffecom_prepare_expr_ (ffebld expr, ffebld dest UNUSED)
12758 {
12759   ffeinfoBasictype bt;
12760   ffeinfoKindtype kt;
12761   ffetargetCharacterSize sz;
12762   tree tempvar = NULL_TREE;
12763
12764   assert (current_binding_level->prep_state < 2);
12765
12766   if (! expr)
12767     return;
12768
12769   bt = ffeinfo_basictype (ffebld_info (expr));
12770   kt = ffeinfo_kindtype (ffebld_info (expr));
12771   sz = ffeinfo_size (ffebld_info (expr));
12772
12773   /* Generate whatever temporaries are needed to represent the result
12774      of the expression.  */
12775
12776   if (bt == FFEINFO_basictypeCHARACTER)
12777     {
12778       while (ffebld_op (expr) == FFEBLD_opPAREN)
12779         expr = ffebld_left (expr);
12780     }
12781
12782   switch (ffebld_op (expr))
12783     {
12784     default:
12785       /* Don't make temps for SYMTER, CONTER, etc.  */
12786       if (ffebld_arity (expr) == 0)
12787         break;
12788
12789       switch (bt)
12790         {
12791         case FFEINFO_basictypeCOMPLEX:
12792           if (ffebld_op (expr) == FFEBLD_opFUNCREF)
12793             {
12794               ffesymbol s;
12795
12796               if (ffebld_op (ffebld_left (expr)) != FFEBLD_opSYMTER)
12797                 break;
12798
12799               s = ffebld_symter (ffebld_left (expr));
12800               if (ffesymbol_where (s) == FFEINFO_whereCONSTANT
12801                   || (ffesymbol_where (s) != FFEINFO_whereINTRINSIC
12802                       && ! ffesymbol_is_f2c (s))
12803                   || (ffesymbol_where (s) == FFEINFO_whereINTRINSIC
12804                       && ! ffe_is_f2c_library ()))
12805                 break;
12806             }
12807           else if (ffebld_op (expr) == FFEBLD_opPOWER)
12808             {
12809               /* Requires special treatment.  There's no POW_CC function
12810                  in libg2c, so POW_ZZ is used, which means we always
12811                  need a double-complex temp, not a single-complex.  */
12812               kt = FFEINFO_kindtypeREAL2;
12813             }
12814           else if (ffebld_op (expr) != FFEBLD_opDIVIDE)
12815             /* The other ops don't need temps for complex operands.  */
12816             break;
12817
12818           /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
12819              REAL(C).  See 19990325-0.f, routine `check', for cases.  */
12820           tempvar = ffecom_make_tempvar ("complex",
12821                                          ffecom_tree_type
12822                                          [FFEINFO_basictypeCOMPLEX][kt],
12823                                          FFETARGET_charactersizeNONE,
12824                                          -1);
12825           break;
12826
12827         case FFEINFO_basictypeCHARACTER:
12828           if (ffebld_op (expr) != FFEBLD_opFUNCREF)
12829             break;
12830
12831           if (sz == FFETARGET_charactersizeNONE)
12832             /* ~~Kludge alert!  This should someday be fixed. */
12833             sz = 24;
12834
12835           tempvar = ffecom_make_tempvar ("char", char_type_node, sz, -1);
12836           break;
12837
12838         default:
12839           break;
12840         }
12841       break;
12842
12843 #ifdef HAHA
12844     case FFEBLD_opPOWER:
12845       {
12846         tree rtype, ltype;
12847         tree rtmp, ltmp, result;
12848
12849         ltype = ffecom_type_expr (ffebld_left (expr));
12850         rtype = ffecom_type_expr (ffebld_right (expr));
12851
12852         rtmp = ffecom_make_tempvar (rtype, FFETARGET_charactersizeNONE, -1);
12853         ltmp = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12854         result = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12855
12856         tempvar = make_tree_vec (3);
12857         TREE_VEC_ELT (tempvar, 0) = rtmp;
12858         TREE_VEC_ELT (tempvar, 1) = ltmp;
12859         TREE_VEC_ELT (tempvar, 2) = result;
12860       }
12861       break;
12862 #endif  /* HAHA */
12863
12864     case FFEBLD_opCONCATENATE:
12865       {
12866         /* This gets special handling, because only one set of temps
12867            is needed for a tree of these -- the tree is treated as
12868            a flattened list of concatenations when generating code.  */
12869
12870         ffecomConcatList_ catlist;
12871         tree ltmp, itmp, result;
12872         int count;
12873         int i;
12874
12875         catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
12876         count = ffecom_concat_list_count_ (catlist);
12877
12878         if (count >= 2)
12879           {
12880             ltmp
12881               = ffecom_make_tempvar ("concat_len",
12882                                      ffecom_f2c_ftnlen_type_node,
12883                                      FFETARGET_charactersizeNONE, count);
12884             itmp
12885               = ffecom_make_tempvar ("concat_item",
12886                                      ffecom_f2c_address_type_node,
12887                                      FFETARGET_charactersizeNONE, count);
12888             result
12889               = ffecom_make_tempvar ("concat_res",
12890                                      char_type_node,
12891                                      ffecom_concat_list_maxlen_ (catlist),
12892                                      -1);
12893
12894             tempvar = make_tree_vec (3);
12895             TREE_VEC_ELT (tempvar, 0) = ltmp;
12896             TREE_VEC_ELT (tempvar, 1) = itmp;
12897             TREE_VEC_ELT (tempvar, 2) = result;
12898           }
12899
12900         for (i = 0; i < count; ++i)
12901           ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist,
12902                                                                     i));
12903
12904         ffecom_concat_list_kill_ (catlist);
12905
12906         if (tempvar)
12907           {
12908             ffebld_nonter_set_hook (expr, tempvar);
12909             current_binding_level->prep_state = 1;
12910           }
12911       }
12912       return;
12913
12914     case FFEBLD_opCONVERT:
12915       if (bt == FFEINFO_basictypeCHARACTER
12916           && ((ffebld_size_known (ffebld_left (expr))
12917                == FFETARGET_charactersizeNONE)
12918               || (ffebld_size_known (ffebld_left (expr)) >= sz)))
12919         tempvar = ffecom_make_tempvar ("convert", char_type_node, sz, -1);
12920       break;
12921     }
12922
12923   if (tempvar)
12924     {
12925       ffebld_nonter_set_hook (expr, tempvar);
12926       current_binding_level->prep_state = 1;
12927     }
12928
12929   /* Prepare subexpressions for this expr.  */
12930
12931   switch (ffebld_op (expr))
12932     {
12933     case FFEBLD_opPERCENT_LOC:
12934       ffecom_prepare_ptr_to_expr (ffebld_left (expr));
12935       break;
12936
12937     case FFEBLD_opPERCENT_VAL:
12938     case FFEBLD_opPERCENT_REF:
12939       ffecom_prepare_expr (ffebld_left (expr));
12940       break;
12941
12942     case FFEBLD_opPERCENT_DESCR:
12943       ffecom_prepare_arg_ptr_to_expr (ffebld_left (expr));
12944       break;
12945
12946     case FFEBLD_opITEM:
12947       {
12948         ffebld item;
12949
12950         for (item = expr;
12951              item != NULL;
12952              item = ffebld_trail (item))
12953           if (ffebld_head (item) != NULL)
12954             ffecom_prepare_expr (ffebld_head (item));
12955       }
12956       break;
12957
12958     default:
12959       /* Need to handle character conversion specially.  */
12960       switch (ffebld_arity (expr))
12961         {
12962         case 2:
12963           ffecom_prepare_expr (ffebld_left (expr));
12964           ffecom_prepare_expr (ffebld_right (expr));
12965           break;
12966
12967         case 1:
12968           ffecom_prepare_expr (ffebld_left (expr));
12969           break;
12970
12971         default:
12972           break;
12973         }
12974     }
12975
12976   return;
12977 }
12978
12979 /* Prepare expression for reading and writing.
12980
12981    Like ffecom_prepare_expr, except for expressions to be evaluated
12982    via ffecom_expr_rw.  */
12983
12984 void
12985 ffecom_prepare_expr_rw (tree type, ffebld expr)
12986 {
12987   /* This is all we support for now.  */
12988   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
12989
12990   /* ~~For now, it seems to be the same thing.  */
12991   ffecom_prepare_expr (expr);
12992   return;
12993 }
12994
12995 /* Prepare expression for writing.
12996
12997    Like ffecom_prepare_expr, except for expressions to be evaluated
12998    via ffecom_expr_w.  */
12999
13000 void
13001 ffecom_prepare_expr_w (tree type, ffebld expr)
13002 {
13003   /* This is all we support for now.  */
13004   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
13005
13006   /* ~~For now, it seems to be the same thing.  */
13007   ffecom_prepare_expr (expr);
13008   return;
13009 }
13010
13011 /* Prepare expression for returning.
13012
13013    Like ffecom_prepare_expr, except for expressions to be evaluated
13014    via ffecom_return_expr.  */
13015
13016 void
13017 ffecom_prepare_return_expr (ffebld expr)
13018 {
13019   assert (current_binding_level->prep_state < 2);
13020
13021   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE
13022       && ffecom_is_altreturning_
13023       && expr != NULL)
13024     ffecom_prepare_expr (expr);
13025 }
13026
13027 /* Prepare pointer to expression.
13028
13029    Like ffecom_prepare_expr, except for expressions to be evaluated
13030    via ffecom_ptr_to_expr.  */
13031
13032 void
13033 ffecom_prepare_ptr_to_expr (ffebld expr)
13034 {
13035   /* ~~For now, it seems to be the same thing.  */
13036   ffecom_prepare_expr (expr);
13037   return;
13038 }
13039
13040 /* Transform expression into constant pointer-to-expression tree.
13041
13042    If the expression can be transformed into a pointer-to-expression tree
13043    that is constant, that is done, and the tree returned.  Else NULL_TREE
13044    is returned.
13045
13046    That way, a caller can attempt to provide compile-time initialization
13047    of a variable and, if that fails, *then* choose to start a new block
13048    and resort to using temporaries, as appropriate.  */
13049
13050 tree
13051 ffecom_ptr_to_const_expr (ffebld expr)
13052 {
13053   if (! expr)
13054     return integer_zero_node;
13055
13056   if (ffebld_op (expr) == FFEBLD_opANY)
13057     return error_mark_node;
13058
13059   if (ffebld_arity (expr) == 0
13060       && (ffebld_op (expr) != FFEBLD_opSYMTER
13061           || ffebld_where (expr) == FFEINFO_whereCOMMON
13062           || ffebld_where (expr) == FFEINFO_whereGLOBAL
13063           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
13064     {
13065       tree t;
13066
13067       t = ffecom_ptr_to_expr (expr);
13068       assert (TREE_CONSTANT (t));
13069       return t;
13070     }
13071
13072   return NULL_TREE;
13073 }
13074
13075 /* ffecom_return_expr -- Returns return-value expr given alt return expr
13076
13077    tree rtn;  // NULL_TREE means use expand_null_return()
13078    ffebld expr;  // NULL if no alt return expr to RETURN stmt
13079    rtn = ffecom_return_expr(expr);
13080
13081    Based on the program unit type and other info (like return function
13082    type, return master function type when alternate ENTRY points,
13083    whether subroutine has any alternate RETURN points, etc), returns the
13084    appropriate expression to be returned to the caller, or NULL_TREE
13085    meaning no return value or the caller expects it to be returned somewhere
13086    else (which is handled by other parts of this module).  */
13087
13088 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13089 tree
13090 ffecom_return_expr (ffebld expr)
13091 {
13092   tree rtn;
13093
13094   switch (ffecom_primary_entry_kind_)
13095     {
13096     case FFEINFO_kindPROGRAM:
13097     case FFEINFO_kindBLOCKDATA:
13098       rtn = NULL_TREE;
13099       break;
13100
13101     case FFEINFO_kindSUBROUTINE:
13102       if (!ffecom_is_altreturning_)
13103         rtn = NULL_TREE;        /* No alt returns, never an expr. */
13104       else if (expr == NULL)
13105         rtn = integer_zero_node;
13106       else
13107         rtn = ffecom_expr (expr);
13108       break;
13109
13110     case FFEINFO_kindFUNCTION:
13111       if ((ffecom_multi_retval_ != NULL_TREE)
13112           || (ffesymbol_basictype (ffecom_primary_entry_)
13113               == FFEINFO_basictypeCHARACTER)
13114           || ((ffesymbol_basictype (ffecom_primary_entry_)
13115                == FFEINFO_basictypeCOMPLEX)
13116               && (ffecom_num_entrypoints_ == 0)
13117               && ffesymbol_is_f2c (ffecom_primary_entry_)))
13118         {                       /* Value is returned by direct assignment
13119                                    into (implicit) dummy. */
13120           rtn = NULL_TREE;
13121           break;
13122         }
13123       rtn = ffecom_func_result_;
13124 #if 0
13125       /* Spurious error if RETURN happens before first reference!  So elide
13126          this code.  In particular, for debugging registry, rtn should always
13127          be non-null after all, but TREE_USED won't be set until we encounter
13128          a reference in the code.  Perfectly okay (but weird) code that,
13129          e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
13130          this diagnostic for no reason.  Have people use -O -Wuninitialized
13131          and leave it to the back end to find obviously weird cases.  */
13132
13133       /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
13134          situation; if the return value has never been referenced, it won't
13135          have a tree under 2pass mode. */
13136       if ((rtn == NULL_TREE)
13137           || !TREE_USED (rtn))
13138         {
13139           ffebad_start (FFEBAD_RETURN_VALUE_UNSET);
13140           ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_),
13141                        ffesymbol_where_column (ffecom_primary_entry_));
13142           ffebad_string (ffesymbol_text (ffesymbol_funcresult
13143                                          (ffecom_primary_entry_)));
13144           ffebad_finish ();
13145         }
13146 #endif
13147       break;
13148
13149     default:
13150       assert ("bad unit kind" == NULL);
13151     case FFEINFO_kindANY:
13152       rtn = error_mark_node;
13153       break;
13154     }
13155
13156   return rtn;
13157 }
13158
13159 #endif
13160 /* Do save_expr only if tree is not error_mark_node.  */
13161
13162 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13163 tree
13164 ffecom_save_tree (tree t)
13165 {
13166   return save_expr (t);
13167 }
13168 #endif
13169
13170 /* Start a compound statement (block).  */
13171
13172 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13173 void
13174 ffecom_start_compstmt (void)
13175 {
13176   bison_rule_pushlevel_ ();
13177 }
13178 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
13179
13180 /* Public entry point for front end to access start_decl.  */
13181
13182 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13183 tree
13184 ffecom_start_decl (tree decl, bool is_initialized)
13185 {
13186   DECL_INITIAL (decl) = is_initialized ? error_mark_node : NULL_TREE;
13187   return start_decl (decl, FALSE);
13188 }
13189
13190 #endif
13191 /* ffecom_sym_commit -- Symbol's state being committed to reality
13192
13193    ffesymbol s;
13194    ffecom_sym_commit(s);
13195
13196    Does whatever the backend needs when a symbol is committed after having
13197    been backtrackable for a period of time.  */
13198
13199 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13200 void
13201 ffecom_sym_commit (ffesymbol s UNUSED)
13202 {
13203   assert (!ffesymbol_retractable ());
13204 }
13205
13206 #endif
13207 /* ffecom_sym_end_transition -- Perform end transition on all symbols
13208
13209    ffecom_sym_end_transition();
13210
13211    Does backend-specific stuff and also calls ffest_sym_end_transition
13212    to do the necessary FFE stuff.
13213
13214    Backtracking is never enabled when this fn is called, so don't worry
13215    about it.  */
13216
13217 ffesymbol
13218 ffecom_sym_end_transition (ffesymbol s)
13219 {
13220   ffestorag st;
13221
13222   assert (!ffesymbol_retractable ());
13223
13224   s = ffest_sym_end_transition (s);
13225
13226 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13227   if ((ffesymbol_kind (s) == FFEINFO_kindBLOCKDATA)
13228       && (ffesymbol_where (s) == FFEINFO_whereGLOBAL))
13229     {
13230       ffecom_list_blockdata_
13231         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
13232                                               FFEINTRIN_specNONE,
13233                                               FFEINTRIN_impNONE),
13234                            ffecom_list_blockdata_);
13235     }
13236 #endif
13237
13238   /* This is where we finally notice that a symbol has partial initialization
13239      and finalize it. */
13240
13241   if (ffesymbol_accretion (s) != NULL)
13242     {
13243       assert (ffesymbol_init (s) == NULL);
13244       ffecom_notify_init_symbol (s);
13245     }
13246   else if (((st = ffesymbol_storage (s)) != NULL)
13247            && ((st = ffestorag_parent (st)) != NULL)
13248            && (ffestorag_accretion (st) != NULL))
13249     {
13250       assert (ffestorag_init (st) == NULL);
13251       ffecom_notify_init_storage (st);
13252     }
13253
13254 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13255   if ((ffesymbol_kind (s) == FFEINFO_kindCOMMON)
13256       && (ffesymbol_where (s) == FFEINFO_whereLOCAL)
13257       && (ffesymbol_storage (s) != NULL))
13258     {
13259       ffecom_list_common_
13260         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
13261                                               FFEINTRIN_specNONE,
13262                                               FFEINTRIN_impNONE),
13263                            ffecom_list_common_);
13264     }
13265 #endif
13266
13267   return s;
13268 }
13269
13270 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
13271
13272    ffecom_sym_exec_transition();
13273
13274    Does backend-specific stuff and also calls ffest_sym_exec_transition
13275    to do the necessary FFE stuff.
13276
13277    See the long-winded description in ffecom_sym_learned for info
13278    on handling the situation where backtracking is inhibited.  */
13279
13280 ffesymbol
13281 ffecom_sym_exec_transition (ffesymbol s)
13282 {
13283   s = ffest_sym_exec_transition (s);
13284
13285   return s;
13286 }
13287
13288 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
13289
13290    ffesymbol s;
13291    s = ffecom_sym_learned(s);
13292
13293    Called when a new symbol is seen after the exec transition or when more
13294    info (perhaps) is gained for an UNCERTAIN symbol.  The symbol state when
13295    it arrives here is that all its latest info is updated already, so its
13296    state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
13297    field filled in if its gone through here or exec_transition first, and
13298    so on.
13299
13300    The backend probably wants to check ffesymbol_retractable() to see if
13301    backtracking is in effect.  If so, the FFE's changes to the symbol may
13302    be retracted (undone) or committed (ratified), at which time the
13303    appropriate ffecom_sym_retract or _commit function will be called
13304    for that function.
13305
13306    If the backend has its own backtracking mechanism, great, use it so that
13307    committal is a simple operation.  Though it doesn't make much difference,
13308    I suppose: the reason for tentative symbol evolution in the FFE is to
13309    enable error detection in weird incorrect statements early and to disable
13310    incorrect error detection on a correct statement.  The backend is not
13311    likely to introduce any information that'll get involved in these
13312    considerations, so it is probably just fine that the implementation
13313    model for this fn and for _exec_transition is to not do anything
13314    (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
13315    and instead wait until ffecom_sym_commit is called (which it never
13316    will be as long as we're using ambiguity-detecting statement analysis in
13317    the FFE, which we are initially to shake out the code, but don't depend
13318    on this), otherwise go ahead and do whatever is needed.
13319
13320    In essence, then, when this fn and _exec_transition get called while
13321    backtracking is enabled, a general mechanism would be to flag which (or
13322    both) of these were called (and in what order? neat question as to what
13323    might happen that I'm too lame to think through right now) and then when
13324    _commit is called reproduce the original calling sequence, if any, for
13325    the two fns (at which point backtracking will, of course, be disabled).  */
13326
13327 ffesymbol
13328 ffecom_sym_learned (ffesymbol s)
13329 {
13330   ffestorag_exec_layout (s);
13331
13332   return s;
13333 }
13334
13335 /* ffecom_sym_retract -- Symbol's state being retracted from reality
13336
13337    ffesymbol s;
13338    ffecom_sym_retract(s);
13339
13340    Does whatever the backend needs when a symbol is retracted after having
13341    been backtrackable for a period of time.  */
13342
13343 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13344 void
13345 ffecom_sym_retract (ffesymbol s UNUSED)
13346 {
13347   assert (!ffesymbol_retractable ());
13348
13349 #if 0                           /* GCC doesn't commit any backtrackable sins,
13350                                    so nothing needed here. */
13351   switch (ffesymbol_hook (s).state)
13352     {
13353     case 0:                     /* nothing happened yet. */
13354       break;
13355
13356     case 1:                     /* exec transition happened. */
13357       break;
13358
13359     case 2:                     /* learned happened. */
13360       break;
13361
13362     case 3:                     /* learned then exec. */
13363       break;
13364
13365     case 4:                     /* exec then learned. */
13366       break;
13367
13368     default:
13369       assert ("bad hook state" == NULL);
13370       break;
13371     }
13372 #endif
13373 }
13374
13375 #endif
13376 /* Create temporary gcc label.  */
13377
13378 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13379 tree
13380 ffecom_temp_label ()
13381 {
13382   tree glabel;
13383   static int mynumber = 0;
13384
13385   glabel = build_decl (LABEL_DECL,
13386                        ffecom_get_invented_identifier ("__g77_label_%d",
13387                                                        mynumber++),
13388                        void_type_node);
13389   DECL_CONTEXT (glabel) = current_function_decl;
13390   DECL_MODE (glabel) = VOIDmode;
13391
13392   return glabel;
13393 }
13394
13395 #endif
13396 /* Return an expression that is usable as an arg in a conditional context
13397    (IF, DO WHILE, .NOT., and so on).
13398
13399    Use the one provided for the back end as of >2.6.0.  */
13400
13401 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13402 tree
13403 ffecom_truth_value (tree expr)
13404 {
13405   return truthvalue_conversion (expr);
13406 }
13407
13408 #endif
13409 /* Return the inversion of a truth value (the inversion of what
13410    ffecom_truth_value builds).
13411
13412    Apparently invert_truthvalue, which is properly in the back end, is
13413    enough for now, so just use it.  */
13414
13415 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13416 tree
13417 ffecom_truth_value_invert (tree expr)
13418 {
13419   return invert_truthvalue (ffecom_truth_value (expr));
13420 }
13421
13422 #endif
13423
13424 /* Return the tree that is the type of the expression, as would be
13425    returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
13426    transforming the expression, generating temporaries, etc.  */
13427
13428 tree
13429 ffecom_type_expr (ffebld expr)
13430 {
13431   ffeinfoBasictype bt;
13432   ffeinfoKindtype kt;
13433   tree tree_type;
13434
13435   assert (expr != NULL);
13436
13437   bt = ffeinfo_basictype (ffebld_info (expr));
13438   kt = ffeinfo_kindtype (ffebld_info (expr));
13439   tree_type = ffecom_tree_type[bt][kt];
13440
13441   switch (ffebld_op (expr))
13442     {
13443     case FFEBLD_opCONTER:
13444     case FFEBLD_opSYMTER:
13445     case FFEBLD_opARRAYREF:
13446     case FFEBLD_opUPLUS:
13447     case FFEBLD_opPAREN:
13448     case FFEBLD_opUMINUS:
13449     case FFEBLD_opADD:
13450     case FFEBLD_opSUBTRACT:
13451     case FFEBLD_opMULTIPLY:
13452     case FFEBLD_opDIVIDE:
13453     case FFEBLD_opPOWER:
13454     case FFEBLD_opNOT:
13455     case FFEBLD_opFUNCREF:
13456     case FFEBLD_opSUBRREF:
13457     case FFEBLD_opAND:
13458     case FFEBLD_opOR:
13459     case FFEBLD_opXOR:
13460     case FFEBLD_opNEQV:
13461     case FFEBLD_opEQV:
13462     case FFEBLD_opCONVERT:
13463     case FFEBLD_opLT:
13464     case FFEBLD_opLE:
13465     case FFEBLD_opEQ:
13466     case FFEBLD_opNE:
13467     case FFEBLD_opGT:
13468     case FFEBLD_opGE:
13469     case FFEBLD_opPERCENT_LOC:
13470       return tree_type;
13471
13472     case FFEBLD_opACCTER:
13473     case FFEBLD_opARRTER:
13474     case FFEBLD_opITEM:
13475     case FFEBLD_opSTAR:
13476     case FFEBLD_opBOUNDS:
13477     case FFEBLD_opREPEAT:
13478     case FFEBLD_opLABTER:
13479     case FFEBLD_opLABTOK:
13480     case FFEBLD_opIMPDO:
13481     case FFEBLD_opCONCATENATE:
13482     case FFEBLD_opSUBSTR:
13483     default:
13484       assert ("bad op for ffecom_type_expr" == NULL);
13485       /* Fall through. */
13486     case FFEBLD_opANY:
13487       return error_mark_node;
13488     }
13489 }
13490
13491 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13492
13493    If the PARM_DECL already exists, return it, else create it.  It's an
13494    integer_type_node argument for the master function that implements a
13495    subroutine or function with more than one entrypoint and is bound at
13496    run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13497    first ENTRY statement, and so on).  */
13498
13499 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13500 tree
13501 ffecom_which_entrypoint_decl ()
13502 {
13503   assert (ffecom_which_entrypoint_decl_ != NULL_TREE);
13504
13505   return ffecom_which_entrypoint_decl_;
13506 }
13507
13508 #endif
13509 \f
13510 /* The following sections consists of private and public functions
13511    that have the same names and perform roughly the same functions
13512    as counterparts in the C front end.  Changes in the C front end
13513    might affect how things should be done here.  Only functions
13514    needed by the back end should be public here; the rest should
13515    be private (static in the C sense).  Functions needed by other
13516    g77 front-end modules should be accessed by them via public
13517    ffecom_* names, which should themselves call private versions
13518    in this section so the private versions are easy to recognize
13519    when upgrading to a new gcc and finding interesting changes
13520    in the front end.
13521
13522    Functions named after rule "foo:" in c-parse.y are named
13523    "bison_rule_foo_" so they are easy to find.  */
13524
13525 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13526
13527 static void
13528 bison_rule_pushlevel_ ()
13529 {
13530   emit_line_note (input_filename, lineno);
13531   pushlevel (0);
13532   clear_last_expr ();
13533   expand_start_bindings (0);
13534 }
13535
13536 static tree
13537 bison_rule_compstmt_ ()
13538 {
13539   tree t;
13540   int keep = kept_level_p ();
13541
13542   /* Make the temps go away.  */
13543   if (! keep)
13544     current_binding_level->names = NULL_TREE;
13545
13546   emit_line_note (input_filename, lineno);
13547   expand_end_bindings (getdecls (), keep, 0);
13548   t = poplevel (keep, 1, 0);
13549
13550   return t;
13551 }
13552
13553 /* Return a definition for a builtin function named NAME and whose data type
13554    is TYPE.  TYPE should be a function type with argument types.
13555    FUNCTION_CODE tells later passes how to compile calls to this function.
13556    See tree.h for its possible values.
13557
13558    If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13559    the name to be called if we can't opencode the function.  */
13560
13561 tree
13562 builtin_function (const char *name, tree type, int function_code,
13563                   enum built_in_class class,
13564                   const char *library_name)
13565 {
13566   tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
13567   DECL_EXTERNAL (decl) = 1;
13568   TREE_PUBLIC (decl) = 1;
13569   if (library_name)
13570     DECL_ASSEMBLER_NAME (decl) = get_identifier (library_name);
13571   make_decl_rtl (decl, NULL_PTR, 1);
13572   pushdecl (decl);
13573   DECL_BUILT_IN_CLASS (decl) = class;
13574   DECL_FUNCTION_CODE (decl) = function_code;
13575
13576   return decl;
13577 }
13578
13579 /* Handle when a new declaration NEWDECL
13580    has the same name as an old one OLDDECL
13581    in the same binding contour.
13582    Prints an error message if appropriate.
13583
13584    If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13585    Otherwise, return 0.  */
13586
13587 static int
13588 duplicate_decls (tree newdecl, tree olddecl)
13589 {
13590   int types_match = 1;
13591   int new_is_definition = (TREE_CODE (newdecl) == FUNCTION_DECL
13592                            && DECL_INITIAL (newdecl) != 0);
13593   tree oldtype = TREE_TYPE (olddecl);
13594   tree newtype = TREE_TYPE (newdecl);
13595
13596   if (olddecl == newdecl)
13597     return 1;
13598
13599   if (TREE_CODE (newtype) == ERROR_MARK
13600       || TREE_CODE (oldtype) == ERROR_MARK)
13601     types_match = 0;
13602
13603   /* New decl is completely inconsistent with the old one =>
13604      tell caller to replace the old one.
13605      This is always an error except in the case of shadowing a builtin.  */
13606   if (TREE_CODE (olddecl) != TREE_CODE (newdecl))
13607     return 0;
13608
13609   /* For real parm decl following a forward decl,
13610      return 1 so old decl will be reused.  */
13611   if (types_match && TREE_CODE (newdecl) == PARM_DECL
13612       && TREE_ASM_WRITTEN (olddecl) && ! TREE_ASM_WRITTEN (newdecl))
13613     return 1;
13614
13615   /* The new declaration is the same kind of object as the old one.
13616      The declarations may partially match.  Print warnings if they don't
13617      match enough.  Ultimately, copy most of the information from the new
13618      decl to the old one, and keep using the old one.  */
13619
13620   if (TREE_CODE (olddecl) == FUNCTION_DECL
13621       && DECL_BUILT_IN (olddecl))
13622     {
13623       /* A function declaration for a built-in function.  */
13624       if (!TREE_PUBLIC (newdecl))
13625         return 0;
13626       else if (!types_match)
13627         {
13628           /* Accept the return type of the new declaration if same modes.  */
13629           tree oldreturntype = TREE_TYPE (TREE_TYPE (olddecl));
13630           tree newreturntype = TREE_TYPE (TREE_TYPE (newdecl));
13631
13632           if (TYPE_MODE (oldreturntype) == TYPE_MODE (newreturntype))
13633             {
13634               /* Function types may be shared, so we can't just modify
13635                  the return type of olddecl's function type.  */
13636               tree newtype
13637                 = build_function_type (newreturntype,
13638                                        TYPE_ARG_TYPES (TREE_TYPE (olddecl)));
13639
13640               types_match = 1;
13641               if (types_match)
13642                 TREE_TYPE (olddecl) = newtype;
13643             }
13644         }
13645       if (!types_match)
13646         return 0;
13647     }
13648   else if (TREE_CODE (olddecl) == FUNCTION_DECL
13649            && DECL_SOURCE_LINE (olddecl) == 0)
13650     {
13651       /* A function declaration for a predeclared function
13652          that isn't actually built in.  */
13653       if (!TREE_PUBLIC (newdecl))
13654         return 0;
13655       else if (!types_match)
13656         {
13657           /* If the types don't match, preserve volatility indication.
13658              Later on, we will discard everything else about the
13659              default declaration.  */
13660           TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl);
13661         }
13662     }
13663
13664   /* Copy all the DECL_... slots specified in the new decl
13665      except for any that we copy here from the old type.
13666
13667      Past this point, we don't change OLDTYPE and NEWTYPE
13668      even if we change the types of NEWDECL and OLDDECL.  */
13669
13670   if (types_match)
13671     {
13672       /* Merge the data types specified in the two decls.  */
13673       if (TREE_CODE (newdecl) != FUNCTION_DECL || !DECL_BUILT_IN (olddecl))
13674         TREE_TYPE (newdecl)
13675           = TREE_TYPE (olddecl)
13676             = TREE_TYPE (newdecl);
13677
13678       /* Lay the type out, unless already done.  */
13679       if (oldtype != TREE_TYPE (newdecl))
13680         {
13681           if (TREE_TYPE (newdecl) != error_mark_node)
13682             layout_type (TREE_TYPE (newdecl));
13683           if (TREE_CODE (newdecl) != FUNCTION_DECL
13684               && TREE_CODE (newdecl) != TYPE_DECL
13685               && TREE_CODE (newdecl) != CONST_DECL)
13686             layout_decl (newdecl, 0);
13687         }
13688       else
13689         {
13690           /* Since the type is OLDDECL's, make OLDDECL's size go with.  */
13691           DECL_SIZE (newdecl) = DECL_SIZE (olddecl);
13692           DECL_SIZE_UNIT (newdecl) = DECL_SIZE_UNIT (olddecl);
13693           if (TREE_CODE (olddecl) != FUNCTION_DECL)
13694             if (DECL_ALIGN (olddecl) > DECL_ALIGN (newdecl))
13695               {
13696                 DECL_ALIGN (newdecl) = DECL_ALIGN (olddecl);
13697                 DECL_USER_ALIGN (newdecl) |= DECL_USER_ALIGN (olddecl);
13698               }
13699         }
13700
13701       /* Keep the old rtl since we can safely use it.  */
13702       DECL_RTL (newdecl) = DECL_RTL (olddecl);
13703
13704       /* Merge the type qualifiers.  */
13705       if (DECL_BUILT_IN_NONANSI (olddecl) && TREE_THIS_VOLATILE (olddecl)
13706           && !TREE_THIS_VOLATILE (newdecl))
13707         TREE_THIS_VOLATILE (olddecl) = 0;
13708       if (TREE_READONLY (newdecl))
13709         TREE_READONLY (olddecl) = 1;
13710       if (TREE_THIS_VOLATILE (newdecl))
13711         {
13712           TREE_THIS_VOLATILE (olddecl) = 1;
13713           if (TREE_CODE (newdecl) == VAR_DECL)
13714             make_var_volatile (newdecl);
13715         }
13716
13717       /* Keep source location of definition rather than declaration.
13718          Likewise, keep decl at outer scope.  */
13719       if ((DECL_INITIAL (newdecl) == 0 && DECL_INITIAL (olddecl) != 0)
13720           || (DECL_CONTEXT (newdecl) != 0 && DECL_CONTEXT (olddecl) == 0))
13721         {
13722           DECL_SOURCE_LINE (newdecl) = DECL_SOURCE_LINE (olddecl);
13723           DECL_SOURCE_FILE (newdecl) = DECL_SOURCE_FILE (olddecl);
13724
13725           if (DECL_CONTEXT (olddecl) == 0
13726               && TREE_CODE (newdecl) != FUNCTION_DECL)
13727             DECL_CONTEXT (newdecl) = 0;
13728         }
13729
13730       /* Merge the unused-warning information.  */
13731       if (DECL_IN_SYSTEM_HEADER (olddecl))
13732         DECL_IN_SYSTEM_HEADER (newdecl) = 1;
13733       else if (DECL_IN_SYSTEM_HEADER (newdecl))
13734         DECL_IN_SYSTEM_HEADER (olddecl) = 1;
13735
13736       /* Merge the initialization information.  */
13737       if (DECL_INITIAL (newdecl) == 0)
13738         DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13739
13740       /* Merge the section attribute.
13741          We want to issue an error if the sections conflict but that must be
13742          done later in decl_attributes since we are called before attributes
13743          are assigned.  */
13744       if (DECL_SECTION_NAME (newdecl) == NULL_TREE)
13745         DECL_SECTION_NAME (newdecl) = DECL_SECTION_NAME (olddecl);
13746
13747 #if BUILT_FOR_270
13748       if (TREE_CODE (newdecl) == FUNCTION_DECL)
13749         {
13750           DECL_STATIC_CONSTRUCTOR(newdecl) |= DECL_STATIC_CONSTRUCTOR(olddecl);
13751           DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl);
13752         }
13753 #endif
13754     }
13755   /* If cannot merge, then use the new type and qualifiers,
13756      and don't preserve the old rtl.  */
13757   else
13758     {
13759       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13760       TREE_READONLY (olddecl) = TREE_READONLY (newdecl);
13761       TREE_THIS_VOLATILE (olddecl) = TREE_THIS_VOLATILE (newdecl);
13762       TREE_SIDE_EFFECTS (olddecl) = TREE_SIDE_EFFECTS (newdecl);
13763     }
13764
13765   /* Merge the storage class information.  */
13766   /* For functions, static overrides non-static.  */
13767   if (TREE_CODE (newdecl) == FUNCTION_DECL)
13768     {
13769       TREE_PUBLIC (newdecl) &= TREE_PUBLIC (olddecl);
13770       /* This is since we don't automatically
13771          copy the attributes of NEWDECL into OLDDECL.  */
13772       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13773       /* If this clears `static', clear it in the identifier too.  */
13774       if (! TREE_PUBLIC (olddecl))
13775         TREE_PUBLIC (DECL_NAME (olddecl)) = 0;
13776     }
13777   if (DECL_EXTERNAL (newdecl))
13778     {
13779       TREE_STATIC (newdecl) = TREE_STATIC (olddecl);
13780       DECL_EXTERNAL (newdecl) = DECL_EXTERNAL (olddecl);
13781       /* An extern decl does not override previous storage class.  */
13782       TREE_PUBLIC (newdecl) = TREE_PUBLIC (olddecl);
13783     }
13784   else
13785     {
13786       TREE_STATIC (olddecl) = TREE_STATIC (newdecl);
13787       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13788     }
13789
13790   /* If either decl says `inline', this fn is inline,
13791      unless its definition was passed already.  */
13792   if (DECL_INLINE (newdecl) && DECL_INITIAL (olddecl) == 0)
13793     DECL_INLINE (olddecl) = 1;
13794   DECL_INLINE (newdecl) = DECL_INLINE (olddecl);
13795
13796   /* Get rid of any built-in function if new arg types don't match it
13797      or if we have a function definition.  */
13798   if (TREE_CODE (newdecl) == FUNCTION_DECL
13799       && DECL_BUILT_IN (olddecl)
13800       && (!types_match || new_is_definition))
13801     {
13802       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13803       DECL_BUILT_IN_CLASS (olddecl) = NOT_BUILT_IN;
13804     }
13805
13806   /* If redeclaring a builtin function, and not a definition,
13807      it stays built in.
13808      Also preserve various other info from the definition.  */
13809   if (TREE_CODE (newdecl) == FUNCTION_DECL && !new_is_definition)
13810     {
13811       if (DECL_BUILT_IN (olddecl))
13812         {
13813           DECL_BUILT_IN_CLASS (newdecl) = DECL_BUILT_IN_CLASS (olddecl);
13814           DECL_FUNCTION_CODE (newdecl) = DECL_FUNCTION_CODE (olddecl);
13815         }
13816       else
13817         DECL_FRAME_SIZE (newdecl) = DECL_FRAME_SIZE (olddecl);
13818
13819       DECL_RESULT (newdecl) = DECL_RESULT (olddecl);
13820       DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13821       DECL_SAVED_INSNS (newdecl) = DECL_SAVED_INSNS (olddecl);
13822       DECL_ARGUMENTS (newdecl) = DECL_ARGUMENTS (olddecl);
13823     }
13824
13825   /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13826      But preserve olddecl's DECL_UID.  */
13827   {
13828     register unsigned olddecl_uid = DECL_UID (olddecl);
13829
13830     memcpy ((char *) olddecl + sizeof (struct tree_common),
13831             (char *) newdecl + sizeof (struct tree_common),
13832             sizeof (struct tree_decl) - sizeof (struct tree_common));
13833     DECL_UID (olddecl) = olddecl_uid;
13834   }
13835
13836   return 1;
13837 }
13838
13839 /* Finish processing of a declaration;
13840    install its initial value.
13841    If the length of an array type is not known before,
13842    it must be determined now, from the initial value, or it is an error.  */
13843
13844 static void
13845 finish_decl (tree decl, tree init, bool is_top_level)
13846 {
13847   register tree type = TREE_TYPE (decl);
13848   int was_incomplete = (DECL_SIZE (decl) == 0);
13849   bool at_top_level = (current_binding_level == global_binding_level);
13850   bool top_level = is_top_level || at_top_level;
13851
13852   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13853      level anyway.  */
13854   assert (!is_top_level || !at_top_level);
13855
13856   if (TREE_CODE (decl) == PARM_DECL)
13857     assert (init == NULL_TREE);
13858   /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
13859      overlaps DECL_ARG_TYPE.  */
13860   else if (init == NULL_TREE)
13861     assert (DECL_INITIAL (decl) == NULL_TREE);
13862   else
13863     assert (DECL_INITIAL (decl) == error_mark_node);
13864
13865   if (init != NULL_TREE)
13866     {
13867       if (TREE_CODE (decl) != TYPE_DECL)
13868         DECL_INITIAL (decl) = init;
13869       else
13870         {
13871           /* typedef foo = bar; store the type of bar as the type of foo.  */
13872           TREE_TYPE (decl) = TREE_TYPE (init);
13873           DECL_INITIAL (decl) = init = 0;
13874         }
13875     }
13876
13877   /* Deduce size of array from initialization, if not already known */
13878
13879   if (TREE_CODE (type) == ARRAY_TYPE
13880       && TYPE_DOMAIN (type) == 0
13881       && TREE_CODE (decl) != TYPE_DECL)
13882     {
13883       assert (top_level);
13884       assert (was_incomplete);
13885
13886       layout_decl (decl, 0);
13887     }
13888
13889   if (TREE_CODE (decl) == VAR_DECL)
13890     {
13891       if (DECL_SIZE (decl) == NULL_TREE
13892           && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
13893         layout_decl (decl, 0);
13894
13895       if (DECL_SIZE (decl) == NULL_TREE
13896           && (TREE_STATIC (decl)
13897               ?
13898       /* A static variable with an incomplete type is an error if it is
13899          initialized. Also if it is not file scope. Otherwise, let it
13900          through, but if it is not `extern' then it may cause an error
13901          message later.  */
13902               (DECL_INITIAL (decl) != 0 || DECL_CONTEXT (decl) != 0)
13903               :
13904       /* An automatic variable with an incomplete type is an error.  */
13905               !DECL_EXTERNAL (decl)))
13906         {
13907           assert ("storage size not known" == NULL);
13908           abort ();
13909         }
13910
13911       if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
13912           && (DECL_SIZE (decl) != 0)
13913           && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
13914         {
13915           assert ("storage size not constant" == NULL);
13916           abort ();
13917         }
13918     }
13919
13920   /* Output the assembler code and/or RTL code for variables and functions,
13921      unless the type is an undefined structure or union. If not, it will get
13922      done when the type is completed.  */
13923
13924   if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL)
13925     {
13926       rest_of_decl_compilation (decl, NULL,
13927                                 DECL_CONTEXT (decl) == 0,
13928                                 0);
13929
13930       if (DECL_CONTEXT (decl) != 0)
13931         {
13932           /* Recompute the RTL of a local array now if it used to be an
13933              incomplete type.  */
13934           if (was_incomplete
13935               && !TREE_STATIC (decl) && !DECL_EXTERNAL (decl))
13936             {
13937               /* If we used it already as memory, it must stay in memory.  */
13938               TREE_ADDRESSABLE (decl) = TREE_USED (decl);
13939               /* If it's still incomplete now, no init will save it.  */
13940               if (DECL_SIZE (decl) == 0)
13941                 DECL_INITIAL (decl) = 0;
13942               expand_decl (decl);
13943             }
13944           /* Compute and store the initial value.  */
13945           if (TREE_CODE (decl) != FUNCTION_DECL)
13946             expand_decl_init (decl);
13947         }
13948     }
13949   else if (TREE_CODE (decl) == TYPE_DECL)
13950     {
13951       rest_of_decl_compilation (decl, NULL_PTR,
13952                                 DECL_CONTEXT (decl) == 0,
13953                                 0);
13954     }
13955
13956   /* At the end of a declaration, throw away any variable type sizes of types
13957      defined inside that declaration.  There is no use computing them in the
13958      following function definition.  */
13959   if (current_binding_level == global_binding_level)
13960     get_pending_sizes ();
13961 }
13962
13963 /* Finish up a function declaration and compile that function
13964    all the way to assembler language output.  The free the storage
13965    for the function definition.
13966
13967    This is called after parsing the body of the function definition.
13968
13969    NESTED is nonzero if the function being finished is nested in another.  */
13970
13971 static void
13972 finish_function (int nested)
13973 {
13974   register tree fndecl = current_function_decl;
13975
13976   assert (fndecl != NULL_TREE);
13977   if (TREE_CODE (fndecl) != ERROR_MARK)
13978     {
13979       if (nested)
13980         assert (DECL_CONTEXT (fndecl) != NULL_TREE);
13981       else
13982         assert (DECL_CONTEXT (fndecl) == NULL_TREE);
13983     }
13984
13985 /*  TREE_READONLY (fndecl) = 1;
13986     This caused &foo to be of type ptr-to-const-function
13987     which then got a warning when stored in a ptr-to-function variable.  */
13988
13989   poplevel (1, 0, 1);
13990
13991   if (TREE_CODE (fndecl) != ERROR_MARK)
13992     {
13993       BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
13994
13995       /* Must mark the RESULT_DECL as being in this function.  */
13996
13997       DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
13998
13999       /* Obey `register' declarations if `setjmp' is called in this fn.  */
14000       /* Generate rtl for function exit.  */
14001       expand_function_end (input_filename, lineno, 0);
14002
14003       /* If this is a nested function, protect the local variables in the stack
14004          above us from being collected while we're compiling this function.  */
14005       if (nested)
14006         ggc_push_context ();
14007
14008       /* Run the optimizers and output the assembler code for this function.  */
14009       rest_of_compilation (fndecl);
14010
14011       /* Undo the GC context switch.  */
14012       if (nested)
14013         ggc_pop_context ();
14014     }
14015
14016   if (TREE_CODE (fndecl) != ERROR_MARK
14017       && !nested
14018       && DECL_SAVED_INSNS (fndecl) == 0)
14019     {
14020       /* Stop pointing to the local nodes about to be freed.  */
14021       /* But DECL_INITIAL must remain nonzero so we know this was an actual
14022          function definition.  */
14023       /* For a nested function, this is done in pop_f_function_context.  */
14024       /* If rest_of_compilation set this to 0, leave it 0.  */
14025       if (DECL_INITIAL (fndecl) != 0)
14026         DECL_INITIAL (fndecl) = error_mark_node;
14027       DECL_ARGUMENTS (fndecl) = 0;
14028     }
14029
14030   if (!nested)
14031     {
14032       /* Let the error reporting routines know that we're outside a function.
14033          For a nested function, this value is used in pop_c_function_context
14034          and then reset via pop_function_context.  */
14035       ffecom_outer_function_decl_ = current_function_decl = NULL;
14036     }
14037 }
14038
14039 /* Plug-in replacement for identifying the name of a decl and, for a
14040    function, what we call it in diagnostics.  For now, "program unit"
14041    should suffice, since it's a bit of a hassle to figure out which
14042    of several kinds of things it is.  Note that it could conceivably
14043    be a statement function, which probably isn't really a program unit
14044    per se, but if that comes up, it should be easy to check (being a
14045    nested function and all).  */
14046
14047 static const char *
14048 lang_printable_name (tree decl, int v)
14049 {
14050   /* Just to keep GCC quiet about the unused variable.
14051      In theory, differing values of V should produce different
14052      output.  */
14053   switch (v)
14054     {
14055     default:
14056       if (TREE_CODE (decl) == ERROR_MARK)
14057         return "erroneous code";
14058       return IDENTIFIER_POINTER (DECL_NAME (decl));
14059     }
14060 }
14061
14062 /* g77's function to print out name of current function that caused
14063    an error.  */
14064
14065 #if BUILT_FOR_270
14066 static void
14067 lang_print_error_function (const char *file)
14068 {
14069   static ffeglobal last_g = NULL;
14070   static ffesymbol last_s = NULL;
14071   ffeglobal g;
14072   ffesymbol s;
14073   const char *kind;
14074
14075   if ((ffecom_primary_entry_ == NULL)
14076       || (ffesymbol_global (ffecom_primary_entry_) == NULL))
14077     {
14078       g = NULL;
14079       s = NULL;
14080       kind = NULL;
14081     }
14082   else
14083     {
14084       g = ffesymbol_global (ffecom_primary_entry_);
14085       if (ffecom_nested_entry_ == NULL)
14086         {
14087           s = ffecom_primary_entry_;
14088           switch (ffesymbol_kind (s))
14089             {
14090             case FFEINFO_kindFUNCTION:
14091               kind = "function";
14092               break;
14093
14094             case FFEINFO_kindSUBROUTINE:
14095               kind = "subroutine";
14096               break;
14097
14098             case FFEINFO_kindPROGRAM:
14099               kind = "program";
14100               break;
14101
14102             case FFEINFO_kindBLOCKDATA:
14103               kind = "block-data";
14104               break;
14105
14106             default:
14107               kind = ffeinfo_kind_message (ffesymbol_kind (s));
14108               break;
14109             }
14110         }
14111       else
14112         {
14113           s = ffecom_nested_entry_;
14114           kind = "statement function";
14115         }
14116     }
14117
14118   if ((last_g != g) || (last_s != s))
14119     {
14120       if (file)
14121         fprintf (stderr, "%s: ", file);
14122
14123       if (s == NULL)
14124         fprintf (stderr, "Outside of any program unit:\n");
14125       else
14126         {
14127           const char *name = ffesymbol_text (s);
14128
14129           fprintf (stderr, "In %s `%s':\n", kind, name);
14130         }
14131
14132       last_g = g;
14133       last_s = s;
14134     }
14135 }
14136 #endif
14137
14138 /* Similar to `lookup_name' but look only at current binding level.  */
14139
14140 static tree
14141 lookup_name_current_level (tree name)
14142 {
14143   register tree t;
14144
14145   if (current_binding_level == global_binding_level)
14146     return IDENTIFIER_GLOBAL_VALUE (name);
14147
14148   if (IDENTIFIER_LOCAL_VALUE (name) == 0)
14149     return 0;
14150
14151   for (t = current_binding_level->names; t; t = TREE_CHAIN (t))
14152     if (DECL_NAME (t) == name)
14153       break;
14154
14155   return t;
14156 }
14157
14158 /* Create a new `struct binding_level'.  */
14159
14160 static struct binding_level *
14161 make_binding_level ()
14162 {
14163   /* NOSTRICT */
14164   return (struct binding_level *) xmalloc (sizeof (struct binding_level));
14165 }
14166
14167 /* Save and restore the variables in this file and elsewhere
14168    that keep track of the progress of compilation of the current function.
14169    Used for nested functions.  */
14170
14171 struct f_function
14172 {
14173   struct f_function *next;
14174   tree named_labels;
14175   tree shadowed_labels;
14176   struct binding_level *binding_level;
14177 };
14178
14179 struct f_function *f_function_chain;
14180
14181 /* Restore the variables used during compilation of a C function.  */
14182
14183 static void
14184 pop_f_function_context ()
14185 {
14186   struct f_function *p = f_function_chain;
14187   tree link;
14188
14189   /* Bring back all the labels that were shadowed.  */
14190   for (link = shadowed_labels; link; link = TREE_CHAIN (link))
14191     if (DECL_NAME (TREE_VALUE (link)) != 0)
14192       IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link)))
14193         = TREE_VALUE (link);
14194
14195   if (current_function_decl != error_mark_node
14196       && DECL_SAVED_INSNS (current_function_decl) == 0)
14197     {
14198       /* Stop pointing to the local nodes about to be freed.  */
14199       /* But DECL_INITIAL must remain nonzero so we know this was an actual
14200          function definition.  */
14201       DECL_INITIAL (current_function_decl) = error_mark_node;
14202       DECL_ARGUMENTS (current_function_decl) = 0;
14203     }
14204
14205   pop_function_context ();
14206
14207   f_function_chain = p->next;
14208
14209   named_labels = p->named_labels;
14210   shadowed_labels = p->shadowed_labels;
14211   current_binding_level = p->binding_level;
14212
14213   free (p);
14214 }
14215
14216 /* Save and reinitialize the variables
14217    used during compilation of a C function.  */
14218
14219 static void
14220 push_f_function_context ()
14221 {
14222   struct f_function *p
14223   = (struct f_function *) xmalloc (sizeof (struct f_function));
14224
14225   push_function_context ();
14226
14227   p->next = f_function_chain;
14228   f_function_chain = p;
14229
14230   p->named_labels = named_labels;
14231   p->shadowed_labels = shadowed_labels;
14232   p->binding_level = current_binding_level;
14233 }
14234
14235 static void
14236 push_parm_decl (tree parm)
14237 {
14238   int old_immediate_size_expand = immediate_size_expand;
14239
14240   /* Don't try computing parm sizes now -- wait till fn is called.  */
14241
14242   immediate_size_expand = 0;
14243
14244   /* Fill in arg stuff.  */
14245
14246   DECL_ARG_TYPE (parm) = TREE_TYPE (parm);
14247   DECL_ARG_TYPE_AS_WRITTEN (parm) = TREE_TYPE (parm);
14248   TREE_READONLY (parm) = 1;     /* All implementation args are read-only. */
14249
14250   parm = pushdecl (parm);
14251
14252   immediate_size_expand = old_immediate_size_expand;
14253
14254   finish_decl (parm, NULL_TREE, FALSE);
14255 }
14256
14257 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate.  */
14258
14259 static tree
14260 pushdecl_top_level (x)
14261      tree x;
14262 {
14263   register tree t;
14264   register struct binding_level *b = current_binding_level;
14265   register tree f = current_function_decl;
14266
14267   current_binding_level = global_binding_level;
14268   current_function_decl = NULL_TREE;
14269   t = pushdecl (x);
14270   current_binding_level = b;
14271   current_function_decl = f;
14272   return t;
14273 }
14274
14275 /* Store the list of declarations of the current level.
14276    This is done for the parameter declarations of a function being defined,
14277    after they are modified in the light of any missing parameters.  */
14278
14279 static tree
14280 storedecls (decls)
14281      tree decls;
14282 {
14283   return current_binding_level->names = decls;
14284 }
14285
14286 /* Store the parameter declarations into the current function declaration.
14287    This is called after parsing the parameter declarations, before
14288    digesting the body of the function.
14289
14290    For an old-style definition, modify the function's type
14291    to specify at least the number of arguments.  */
14292
14293 static void
14294 store_parm_decls (int is_main_program UNUSED)
14295 {
14296   register tree fndecl = current_function_decl;
14297
14298   if (fndecl == error_mark_node)
14299     return;
14300
14301   /* This is a chain of PARM_DECLs from old-style parm declarations.  */
14302   DECL_ARGUMENTS (fndecl) = storedecls (nreverse (getdecls ()));
14303
14304   /* Initialize the RTL code for the function.  */
14305
14306   init_function_start (fndecl, input_filename, lineno);
14307
14308   /* Set up parameters and prepare for return, for the function.  */
14309
14310   expand_function_start (fndecl, 0);
14311 }
14312
14313 static tree
14314 start_decl (tree decl, bool is_top_level)
14315 {
14316   register tree tem;
14317   bool at_top_level = (current_binding_level == global_binding_level);
14318   bool top_level = is_top_level || at_top_level;
14319
14320   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
14321      level anyway.  */
14322   assert (!is_top_level || !at_top_level);
14323
14324   if (DECL_INITIAL (decl) != NULL_TREE)
14325     {
14326       assert (DECL_INITIAL (decl) == error_mark_node);
14327       assert (!DECL_EXTERNAL (decl));
14328     }
14329   else if (top_level)
14330     assert ((TREE_STATIC (decl) == 1) || DECL_EXTERNAL (decl) == 1);
14331
14332   /* For Fortran, we by default put things in .common when possible.  */
14333   DECL_COMMON (decl) = 1;
14334
14335   /* Add this decl to the current binding level. TEM may equal DECL or it may
14336      be a previous decl of the same name.  */
14337   if (is_top_level)
14338     tem = pushdecl_top_level (decl);
14339   else
14340     tem = pushdecl (decl);
14341
14342   /* For a local variable, define the RTL now.  */
14343   if (!top_level
14344   /* But not if this is a duplicate decl and we preserved the rtl from the
14345      previous one (which may or may not happen).  */
14346       && DECL_RTL (tem) == 0)
14347     {
14348       if (TYPE_SIZE (TREE_TYPE (tem)) != 0)
14349         expand_decl (tem);
14350       else if (TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE
14351                && DECL_INITIAL (tem) != 0)
14352         expand_decl (tem);
14353     }
14354
14355   return tem;
14356 }
14357
14358 /* Create the FUNCTION_DECL for a function definition.
14359    DECLSPECS and DECLARATOR are the parts of the declaration;
14360    they describe the function's name and the type it returns,
14361    but twisted together in a fashion that parallels the syntax of C.
14362
14363    This function creates a binding context for the function body
14364    as well as setting up the FUNCTION_DECL in current_function_decl.
14365
14366    Returns 1 on success.  If the DECLARATOR is not suitable for a function
14367    (it defines a datum instead), we return 0, which tells
14368    yyparse to report a parse error.
14369
14370    NESTED is nonzero for a function nested within another function.  */
14371
14372 static void
14373 start_function (tree name, tree type, int nested, int public)
14374 {
14375   tree decl1;
14376   tree restype;
14377   int old_immediate_size_expand = immediate_size_expand;
14378
14379   named_labels = 0;
14380   shadowed_labels = 0;
14381
14382   /* Don't expand any sizes in the return type of the function.  */
14383   immediate_size_expand = 0;
14384
14385   if (nested)
14386     {
14387       assert (!public);
14388       assert (current_function_decl != NULL_TREE);
14389       assert (DECL_CONTEXT (current_function_decl) == NULL_TREE);
14390     }
14391   else
14392     {
14393       assert (current_function_decl == NULL_TREE);
14394     }
14395
14396   if (TREE_CODE (type) == ERROR_MARK)
14397     decl1 = current_function_decl = error_mark_node;
14398   else
14399     {
14400       decl1 = build_decl (FUNCTION_DECL,
14401                           name,
14402                           type);
14403       TREE_PUBLIC (decl1) = public ? 1 : 0;
14404       if (nested)
14405         DECL_INLINE (decl1) = 1;
14406       TREE_STATIC (decl1) = 1;
14407       DECL_EXTERNAL (decl1) = 0;
14408
14409       announce_function (decl1);
14410
14411       /* Make the init_value nonzero so pushdecl knows this is not tentative.
14412          error_mark_node is replaced below (in poplevel) with the BLOCK.  */
14413       DECL_INITIAL (decl1) = error_mark_node;
14414
14415       /* Record the decl so that the function name is defined. If we already have
14416          a decl for this name, and it is a FUNCTION_DECL, use the old decl.  */
14417
14418       current_function_decl = pushdecl (decl1);
14419     }
14420
14421   if (!nested)
14422     ffecom_outer_function_decl_ = current_function_decl;
14423
14424   pushlevel (0);
14425   current_binding_level->prep_state = 2;
14426
14427   if (TREE_CODE (current_function_decl) != ERROR_MARK)
14428     {
14429       make_function_rtl (current_function_decl);
14430
14431       restype = TREE_TYPE (TREE_TYPE (current_function_decl));
14432       DECL_RESULT (current_function_decl)
14433         = build_decl (RESULT_DECL, NULL_TREE, restype);
14434     }
14435
14436   if (!nested && (TREE_CODE (current_function_decl) != ERROR_MARK))
14437     TREE_ADDRESSABLE (current_function_decl) = 1;
14438
14439   immediate_size_expand = old_immediate_size_expand;
14440 }
14441 \f
14442 /* Here are the public functions the GNU back end needs.  */
14443
14444 tree
14445 convert (type, expr)
14446      tree type, expr;
14447 {
14448   register tree e = expr;
14449   register enum tree_code code = TREE_CODE (type);
14450
14451   if (type == TREE_TYPE (e)
14452       || TREE_CODE (e) == ERROR_MARK)
14453     return e;
14454   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
14455     return fold (build1 (NOP_EXPR, type, e));
14456   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
14457       || code == ERROR_MARK)
14458     return error_mark_node;
14459   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
14460     {
14461       assert ("void value not ignored as it ought to be" == NULL);
14462       return error_mark_node;
14463     }
14464   if (code == VOID_TYPE)
14465     return build1 (CONVERT_EXPR, type, e);
14466   if ((code != RECORD_TYPE)
14467       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
14468     e = ffecom_1 (REALPART_EXPR, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))),
14469                   e);
14470   if (code == INTEGER_TYPE || code == ENUMERAL_TYPE)
14471     return fold (convert_to_integer (type, e));
14472   if (code == POINTER_TYPE)
14473     return fold (convert_to_pointer (type, e));
14474   if (code == REAL_TYPE)
14475     return fold (convert_to_real (type, e));
14476   if (code == COMPLEX_TYPE)
14477     return fold (convert_to_complex (type, e));
14478   if (code == RECORD_TYPE)
14479     return fold (ffecom_convert_to_complex_ (type, e));
14480
14481   assert ("conversion to non-scalar type requested" == NULL);
14482   return error_mark_node;
14483 }
14484
14485 /* integrate_decl_tree calls this function, but since we don't use the
14486    DECL_LANG_SPECIFIC field, this is a no-op.  */
14487
14488 void
14489 copy_lang_decl (node)
14490      tree node UNUSED;
14491 {
14492 }
14493
14494 /* Return the list of declarations of the current level.
14495    Note that this list is in reverse order unless/until
14496    you nreverse it; and when you do nreverse it, you must
14497    store the result back using `storedecls' or you will lose.  */
14498
14499 tree
14500 getdecls ()
14501 {
14502   return current_binding_level->names;
14503 }
14504
14505 /* Nonzero if we are currently in the global binding level.  */
14506
14507 int
14508 global_bindings_p ()
14509 {
14510   return current_binding_level == global_binding_level;
14511 }
14512
14513 /* Print an error message for invalid use of an incomplete type.
14514    VALUE is the expression that was used (or 0 if that isn't known)
14515    and TYPE is the type that was invalid.  */
14516
14517 void
14518 incomplete_type_error (value, type)
14519      tree value UNUSED;
14520      tree type;
14521 {
14522   if (TREE_CODE (type) == ERROR_MARK)
14523     return;
14524
14525   assert ("incomplete type?!?" == NULL);
14526 }
14527
14528 /* Mark ARG for GC.  */
14529 static void
14530 mark_binding_level (void *arg)
14531 {
14532   struct binding_level *level = *(struct binding_level **) arg;
14533
14534   while (level)
14535     {
14536       ggc_mark_tree (level->names);
14537       ggc_mark_tree (level->blocks);
14538       ggc_mark_tree (level->this_block);
14539       level = level->level_chain;
14540     }
14541 }
14542
14543 void
14544 init_decl_processing ()
14545 {
14546   static tree *const tree_roots[] = {
14547     &current_function_decl,
14548     &string_type_node,
14549     &ffecom_tree_fun_type_void,
14550     &ffecom_integer_zero_node,
14551     &ffecom_integer_one_node,
14552     &ffecom_tree_subr_type,
14553     &ffecom_tree_ptr_to_subr_type,
14554     &ffecom_tree_blockdata_type,
14555     &ffecom_tree_xargc_,
14556     &ffecom_f2c_integer_type_node,
14557     &ffecom_f2c_ptr_to_integer_type_node,
14558     &ffecom_f2c_address_type_node,
14559     &ffecom_f2c_real_type_node,
14560     &ffecom_f2c_ptr_to_real_type_node,
14561     &ffecom_f2c_doublereal_type_node,
14562     &ffecom_f2c_complex_type_node,
14563     &ffecom_f2c_doublecomplex_type_node,
14564     &ffecom_f2c_longint_type_node,
14565     &ffecom_f2c_logical_type_node,
14566     &ffecom_f2c_flag_type_node,
14567     &ffecom_f2c_ftnlen_type_node,
14568     &ffecom_f2c_ftnlen_zero_node,
14569     &ffecom_f2c_ftnlen_one_node,
14570     &ffecom_f2c_ftnlen_two_node,
14571     &ffecom_f2c_ptr_to_ftnlen_type_node,
14572     &ffecom_f2c_ftnint_type_node,
14573     &ffecom_f2c_ptr_to_ftnint_type_node,
14574     &ffecom_outer_function_decl_,
14575     &ffecom_previous_function_decl_,
14576     &ffecom_which_entrypoint_decl_,
14577     &ffecom_float_zero_,
14578     &ffecom_float_half_,
14579     &ffecom_double_zero_,
14580     &ffecom_double_half_,
14581     &ffecom_func_result_,
14582     &ffecom_func_length_,
14583     &ffecom_multi_type_node_,
14584     &ffecom_multi_retval_,
14585     &named_labels,
14586     &shadowed_labels
14587   };
14588   size_t i;
14589
14590   malloc_init ();
14591
14592   /* Record our roots.  */
14593   for (i = 0; i < ARRAY_SIZE (tree_roots); i++)
14594     ggc_add_tree_root (tree_roots[i], 1);
14595   ggc_add_tree_root (&ffecom_tree_type[0][0],
14596                      FFEINFO_basictype*FFEINFO_kindtype);
14597   ggc_add_tree_root (&ffecom_tree_fun_type[0][0],
14598                      FFEINFO_basictype*FFEINFO_kindtype);
14599   ggc_add_tree_root (&ffecom_tree_ptr_to_fun_type[0][0],
14600                      FFEINFO_basictype*FFEINFO_kindtype);
14601   ggc_add_tree_root (ffecom_gfrt_, FFECOM_gfrt);
14602   ggc_add_root (&current_binding_level, 1, sizeof current_binding_level,
14603                 mark_binding_level);
14604   ggc_add_root (&free_binding_level, 1, sizeof current_binding_level,
14605                 mark_binding_level);
14606   ggc_add_root (&tracker_head, 1, sizeof tracker_head, mark_tracker_head);
14607
14608   ffe_init_0 ();
14609 }
14610
14611 const char *
14612 init_parse (filename)
14613      const char *filename;
14614 {
14615   /* Open input file.  */
14616   if (filename == 0 || !strcmp (filename, "-"))
14617     {
14618       finput = stdin;
14619       filename = "stdin";
14620     }
14621   else
14622     finput = fopen (filename, "r");
14623   if (finput == 0)
14624     pfatal_with_name (filename);
14625
14626 #ifdef IO_BUFFER_SIZE
14627   setvbuf (finput, (char *) xmalloc (IO_BUFFER_SIZE), _IOFBF, IO_BUFFER_SIZE);
14628 #endif
14629
14630   /* Make identifier nodes long enough for the language-specific slots.  */
14631   set_identifier_size (sizeof (struct lang_identifier));
14632   decl_printable_name = lang_printable_name;
14633 #if BUILT_FOR_270
14634   print_error_function = lang_print_error_function;
14635 #endif
14636
14637   return filename;
14638 }
14639
14640 void
14641 finish_parse ()
14642 {
14643   fclose (finput);
14644 }
14645
14646 /* Delete the node BLOCK from the current binding level.
14647    This is used for the block inside a stmt expr ({...})
14648    so that the block can be reinserted where appropriate.  */
14649
14650 static void
14651 delete_block (block)
14652      tree block;
14653 {
14654   tree t;
14655   if (current_binding_level->blocks == block)
14656     current_binding_level->blocks = TREE_CHAIN (block);
14657   for (t = current_binding_level->blocks; t;)
14658     {
14659       if (TREE_CHAIN (t) == block)
14660         TREE_CHAIN (t) = TREE_CHAIN (block);
14661       else
14662         t = TREE_CHAIN (t);
14663     }
14664   TREE_CHAIN (block) = NULL;
14665   /* Clear TREE_USED which is always set by poplevel.
14666      The flag is set again if insert_block is called.  */
14667   TREE_USED (block) = 0;
14668 }
14669
14670 void
14671 insert_block (block)
14672      tree block;
14673 {
14674   TREE_USED (block) = 1;
14675   current_binding_level->blocks
14676     = chainon (current_binding_level->blocks, block);
14677 }
14678
14679 /* Each front end provides its own.  */
14680 static void ffe_init PARAMS ((void));
14681 static void ffe_finish PARAMS ((void));
14682 static void ffe_init_options PARAMS ((void));
14683
14684 struct lang_hooks lang_hooks = {ffe_init,
14685                                 ffe_finish,
14686                                 ffe_init_options,
14687                                 ffe_decode_option,
14688                                 NULL /* post_options */};
14689
14690 /* used by print-tree.c */
14691
14692 void
14693 lang_print_xnode (file, node, indent)
14694      FILE *file UNUSED;
14695      tree node UNUSED;
14696      int indent UNUSED;
14697 {
14698 }
14699
14700 static void
14701 ffe_finish ()
14702 {
14703   ffe_terminate_0 ();
14704
14705   if (ffe_is_ffedebug ())
14706     malloc_pool_display (malloc_pool_image ());
14707 }
14708
14709 const char *
14710 lang_identify ()
14711 {
14712   return "f77";
14713 }
14714
14715 /* Return the typed-based alias set for T, which may be an expression
14716    or a type.  Return -1 if we don't do anything special.  */
14717
14718 HOST_WIDE_INT
14719 lang_get_alias_set (t)
14720      tree t ATTRIBUTE_UNUSED;
14721 {
14722   /* We do not wish to use alias-set based aliasing at all.  Used in the
14723      extreme (every object with its own set, with equivalences recorded)
14724      it might be helpful, but there are problems when it comes to inlining.
14725      We get on ok with flag_argument_noalias, and alias-set aliasing does
14726      currently limit how stack slots can be reused, which is a lose.  */
14727   return 0;
14728 }
14729
14730 static void
14731 ffe_init_options ()
14732 {
14733   /* Set default options for Fortran.  */
14734   flag_move_all_movables = 1;
14735   flag_reduce_all_givs = 1;
14736   flag_argument_noalias = 2;
14737   flag_errno_math = 0;
14738   flag_complex_divide_method = 1;
14739 }
14740
14741 static void
14742 ffe_init ()
14743 {
14744   /* If the file is output from cpp, it should contain a first line
14745      `# 1 "real-filename"', and the current design of gcc (toplev.c
14746      in particular and the way it sets up information relied on by
14747      INCLUDE) requires that we read this now, and store the
14748      "real-filename" info in master_input_filename.  Ask the lexer
14749      to try doing this.  */
14750   ffelex_hash_kludge (finput);
14751 }
14752
14753 int
14754 mark_addressable (exp)
14755      tree exp;
14756 {
14757   register tree x = exp;
14758   while (1)
14759     switch (TREE_CODE (x))
14760       {
14761       case ADDR_EXPR:
14762       case COMPONENT_REF:
14763       case ARRAY_REF:
14764         x = TREE_OPERAND (x, 0);
14765         break;
14766
14767       case CONSTRUCTOR:
14768         TREE_ADDRESSABLE (x) = 1;
14769         return 1;
14770
14771       case VAR_DECL:
14772       case CONST_DECL:
14773       case PARM_DECL:
14774       case RESULT_DECL:
14775         if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)
14776             && DECL_NONLOCAL (x))
14777           {
14778             if (TREE_PUBLIC (x))
14779               {
14780                 assert ("address of global register var requested" == NULL);
14781                 return 0;
14782               }
14783             assert ("address of register variable requested" == NULL);
14784           }
14785         else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
14786           {
14787             if (TREE_PUBLIC (x))
14788               {
14789                 assert ("address of global register var requested" == NULL);
14790                 return 0;
14791               }
14792             assert ("address of register var requested" == NULL);
14793           }
14794         put_var_into_stack (x);
14795
14796         /* drops in */
14797       case FUNCTION_DECL:
14798         TREE_ADDRESSABLE (x) = 1;
14799 #if 0                           /* poplevel deals with this now.  */
14800         if (DECL_CONTEXT (x) == 0)
14801           TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1;
14802 #endif
14803
14804       default:
14805         return 1;
14806       }
14807 }
14808
14809 /* If DECL has a cleanup, build and return that cleanup here.
14810    This is a callback called by expand_expr.  */
14811
14812 tree
14813 maybe_build_cleanup (decl)
14814      tree decl UNUSED;
14815 {
14816   /* There are no cleanups in Fortran.  */
14817   return NULL_TREE;
14818 }
14819
14820 /* Exit a binding level.
14821    Pop the level off, and restore the state of the identifier-decl mappings
14822    that were in effect when this level was entered.
14823
14824    If KEEP is nonzero, this level had explicit declarations, so
14825    and create a "block" (a BLOCK node) for the level
14826    to record its declarations and subblocks for symbol table output.
14827
14828    If FUNCTIONBODY is nonzero, this level is the body of a function,
14829    so create a block as if KEEP were set and also clear out all
14830    label names.
14831
14832    If REVERSE is nonzero, reverse the order of decls before putting
14833    them into the BLOCK.  */
14834
14835 tree
14836 poplevel (keep, reverse, functionbody)
14837      int keep;
14838      int reverse;
14839      int functionbody;
14840 {
14841   register tree link;
14842   /* The chain of decls was accumulated in reverse order.
14843      Put it into forward order, just for cleanliness.  */
14844   tree decls;
14845   tree subblocks = current_binding_level->blocks;
14846   tree block = 0;
14847   tree decl;
14848   int block_previously_created;
14849
14850   /* Get the decls in the order they were written.
14851      Usually current_binding_level->names is in reverse order.
14852      But parameter decls were previously put in forward order.  */
14853
14854   if (reverse)
14855     current_binding_level->names
14856       = decls = nreverse (current_binding_level->names);
14857   else
14858     decls = current_binding_level->names;
14859
14860   /* Output any nested inline functions within this block
14861      if they weren't already output.  */
14862
14863   for (decl = decls; decl; decl = TREE_CHAIN (decl))
14864     if (TREE_CODE (decl) == FUNCTION_DECL
14865         && ! TREE_ASM_WRITTEN (decl)
14866         && DECL_INITIAL (decl) != 0
14867         && TREE_ADDRESSABLE (decl))
14868       {
14869         /* If this decl was copied from a file-scope decl
14870            on account of a block-scope extern decl,
14871            propagate TREE_ADDRESSABLE to the file-scope decl.
14872
14873            DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
14874            true, since then the decl goes through save_for_inline_copying.  */
14875         if (DECL_ABSTRACT_ORIGIN (decl) != 0
14876             && DECL_ABSTRACT_ORIGIN (decl) != decl)
14877           TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1;
14878         else if (DECL_SAVED_INSNS (decl) != 0)
14879           {
14880             push_function_context ();
14881             output_inline_function (decl);
14882             pop_function_context ();
14883           }
14884       }
14885
14886   /* If there were any declarations or structure tags in that level,
14887      or if this level is a function body,
14888      create a BLOCK to record them for the life of this function.  */
14889
14890   block = 0;
14891   block_previously_created = (current_binding_level->this_block != 0);
14892   if (block_previously_created)
14893     block = current_binding_level->this_block;
14894   else if (keep || functionbody)
14895     block = make_node (BLOCK);
14896   if (block != 0)
14897     {
14898       BLOCK_VARS (block) = decls;
14899       BLOCK_SUBBLOCKS (block) = subblocks;
14900     }
14901
14902   /* In each subblock, record that this is its superior.  */
14903
14904   for (link = subblocks; link; link = TREE_CHAIN (link))
14905     BLOCK_SUPERCONTEXT (link) = block;
14906
14907   /* Clear out the meanings of the local variables of this level.  */
14908
14909   for (link = decls; link; link = TREE_CHAIN (link))
14910     {
14911       if (DECL_NAME (link) != 0)
14912         {
14913           /* If the ident. was used or addressed via a local extern decl,
14914              don't forget that fact.  */
14915           if (DECL_EXTERNAL (link))
14916             {
14917               if (TREE_USED (link))
14918                 TREE_USED (DECL_NAME (link)) = 1;
14919               if (TREE_ADDRESSABLE (link))
14920                 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link)) = 1;
14921             }
14922           IDENTIFIER_LOCAL_VALUE (DECL_NAME (link)) = 0;
14923         }
14924     }
14925
14926   /* If the level being exited is the top level of a function,
14927      check over all the labels, and clear out the current
14928      (function local) meanings of their names.  */
14929
14930   if (functionbody)
14931     {
14932       /* If this is the top level block of a function,
14933          the vars are the function's parameters.
14934          Don't leave them in the BLOCK because they are
14935          found in the FUNCTION_DECL instead.  */
14936
14937       BLOCK_VARS (block) = 0;
14938     }
14939
14940   /* Pop the current level, and free the structure for reuse.  */
14941
14942   {
14943     register struct binding_level *level = current_binding_level;
14944     current_binding_level = current_binding_level->level_chain;
14945
14946     level->level_chain = free_binding_level;
14947     free_binding_level = level;
14948   }
14949
14950   /* Dispose of the block that we just made inside some higher level.  */
14951   if (functionbody
14952       && current_function_decl != error_mark_node)
14953     DECL_INITIAL (current_function_decl) = block;
14954   else if (block)
14955     {
14956       if (!block_previously_created)
14957         current_binding_level->blocks
14958           = chainon (current_binding_level->blocks, block);
14959     }
14960   /* If we did not make a block for the level just exited,
14961      any blocks made for inner levels
14962      (since they cannot be recorded as subblocks in that level)
14963      must be carried forward so they will later become subblocks
14964      of something else.  */
14965   else if (subblocks)
14966     current_binding_level->blocks
14967       = chainon (current_binding_level->blocks, subblocks);
14968
14969   if (block)
14970     TREE_USED (block) = 1;
14971   return block;
14972 }
14973
14974 void
14975 print_lang_decl (file, node, indent)
14976      FILE *file UNUSED;
14977      tree node UNUSED;
14978      int indent UNUSED;
14979 {
14980 }
14981
14982 void
14983 print_lang_identifier (file, node, indent)
14984      FILE *file;
14985      tree node;
14986      int indent;
14987 {
14988   print_node (file, "global", IDENTIFIER_GLOBAL_VALUE (node), indent + 4);
14989   print_node (file, "local", IDENTIFIER_LOCAL_VALUE (node), indent + 4);
14990 }
14991
14992 void
14993 print_lang_statistics ()
14994 {
14995 }
14996
14997 void
14998 print_lang_type (file, node, indent)
14999      FILE *file UNUSED;
15000      tree node UNUSED;
15001      int indent UNUSED;
15002 {
15003 }
15004
15005 /* Record a decl-node X as belonging to the current lexical scope.
15006    Check for errors (such as an incompatible declaration for the same
15007    name already seen in the same scope).
15008
15009    Returns either X or an old decl for the same name.
15010    If an old decl is returned, it may have been smashed
15011    to agree with what X says.  */
15012
15013 tree
15014 pushdecl (x)
15015      tree x;
15016 {
15017   register tree t;
15018   register tree name = DECL_NAME (x);
15019   register struct binding_level *b = current_binding_level;
15020
15021   if ((TREE_CODE (x) == FUNCTION_DECL)
15022       && (DECL_INITIAL (x) == 0)
15023       && DECL_EXTERNAL (x))
15024     DECL_CONTEXT (x) = NULL_TREE;
15025   else
15026     DECL_CONTEXT (x) = current_function_decl;
15027
15028   if (name)
15029     {
15030       if (IDENTIFIER_INVENTED (name))
15031         {
15032 #if BUILT_FOR_270
15033           DECL_ARTIFICIAL (x) = 1;
15034 #endif
15035           DECL_IN_SYSTEM_HEADER (x) = 1;
15036         }
15037
15038       t = lookup_name_current_level (name);
15039
15040       assert ((t == NULL_TREE) || (DECL_CONTEXT (x) == NULL_TREE));
15041
15042       /* Don't push non-parms onto list for parms until we understand
15043          why we're doing this and whether it works.  */
15044
15045       assert ((b == global_binding_level)
15046               || !ffecom_transform_only_dummies_
15047               || TREE_CODE (x) == PARM_DECL);
15048
15049       if ((t != NULL_TREE) && duplicate_decls (x, t))
15050         return t;
15051
15052       /* If we are processing a typedef statement, generate a whole new
15053          ..._TYPE node (which will be just an variant of the existing
15054          ..._TYPE node with identical properties) and then install the
15055          TYPE_DECL node generated to represent the typedef name as the
15056          TYPE_NAME of this brand new (duplicate) ..._TYPE node.
15057
15058          The whole point here is to end up with a situation where each and every
15059          ..._TYPE node the compiler creates will be uniquely associated with
15060          AT MOST one node representing a typedef name. This way, even though
15061          the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
15062          (i.e. "typedef name") nodes very early on, later parts of the
15063          compiler can always do the reverse translation and get back the
15064          corresponding typedef name.  For example, given:
15065
15066          typedef struct S MY_TYPE; MY_TYPE object;
15067
15068          Later parts of the compiler might only know that `object' was of type
15069          `struct S' if it were not for code just below.  With this code
15070          however, later parts of the compiler see something like:
15071
15072          struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
15073
15074          And they can then deduce (from the node for type struct S') that the
15075          original object declaration was:
15076
15077          MY_TYPE object;
15078
15079          Being able to do this is important for proper support of protoize, and
15080          also for generating precise symbolic debugging information which
15081          takes full account of the programmer's (typedef) vocabulary.
15082
15083          Obviously, we don't want to generate a duplicate ..._TYPE node if the
15084          TYPE_DECL node that we are now processing really represents a
15085          standard built-in type.
15086
15087          Since all standard types are effectively declared at line zero in the
15088          source file, we can easily check to see if we are working on a
15089          standard type by checking the current value of lineno.  */
15090
15091       if (TREE_CODE (x) == TYPE_DECL)
15092         {
15093           if (DECL_SOURCE_LINE (x) == 0)
15094             {
15095               if (TYPE_NAME (TREE_TYPE (x)) == 0)
15096                 TYPE_NAME (TREE_TYPE (x)) = x;
15097             }
15098           else if (TREE_TYPE (x) != error_mark_node)
15099             {
15100               tree tt = TREE_TYPE (x);
15101
15102               tt = build_type_copy (tt);
15103               TYPE_NAME (tt) = x;
15104               TREE_TYPE (x) = tt;
15105             }
15106         }
15107
15108       /* This name is new in its binding level. Install the new declaration
15109          and return it.  */
15110       if (b == global_binding_level)
15111         IDENTIFIER_GLOBAL_VALUE (name) = x;
15112       else
15113         IDENTIFIER_LOCAL_VALUE (name) = x;
15114     }
15115
15116   /* Put decls on list in reverse order. We will reverse them later if
15117      necessary.  */
15118   TREE_CHAIN (x) = b->names;
15119   b->names = x;
15120
15121   return x;
15122 }
15123
15124 /* Nonzero if the current level needs to have a BLOCK made.  */
15125
15126 static int
15127 kept_level_p ()
15128 {
15129   tree decl;
15130
15131   for (decl = current_binding_level->names;
15132        decl;
15133        decl = TREE_CHAIN (decl))
15134     {
15135       if (TREE_USED (decl) || TREE_CODE (decl) != VAR_DECL
15136           || (DECL_NAME (decl) && ! DECL_ARTIFICIAL (decl)))
15137         /* Currently, there aren't supposed to be non-artificial names
15138            at other than the top block for a function -- they're
15139            believed to always be temps.  But it's wise to check anyway.  */
15140         return 1;
15141     }
15142   return 0;
15143 }
15144
15145 /* Enter a new binding level.
15146    If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
15147    not for that of tags.  */
15148
15149 void
15150 pushlevel (tag_transparent)
15151      int tag_transparent;
15152 {
15153   register struct binding_level *newlevel = NULL_BINDING_LEVEL;
15154
15155   assert (! tag_transparent);
15156
15157   if (current_binding_level == global_binding_level)
15158     {
15159       named_labels = 0;
15160     }
15161
15162   /* Reuse or create a struct for this binding level.  */
15163
15164   if (free_binding_level)
15165     {
15166       newlevel = free_binding_level;
15167       free_binding_level = free_binding_level->level_chain;
15168     }
15169   else
15170     {
15171       newlevel = make_binding_level ();
15172     }
15173
15174   /* Add this level to the front of the chain (stack) of levels that
15175      are active.  */
15176
15177   *newlevel = clear_binding_level;
15178   newlevel->level_chain = current_binding_level;
15179   current_binding_level = newlevel;
15180 }
15181
15182 /* Set the BLOCK node for the innermost scope
15183    (the one we are currently in).  */
15184
15185 void
15186 set_block (block)
15187      register tree block;
15188 {
15189   current_binding_level->this_block = block;
15190 }
15191
15192 /* ~~gcc/tree.h *should* declare this, because toplev.c references it.  */
15193
15194 /* Can't 'yydebug' a front end not generated by yacc/bison!  */
15195
15196 void
15197 set_yydebug (value)
15198      int value;
15199 {
15200   if (value)
15201     fprintf (stderr, "warning: no yacc/bison-generated output to debug!\n");
15202 }
15203
15204 tree
15205 signed_or_unsigned_type (unsignedp, type)
15206      int unsignedp;
15207      tree type;
15208 {
15209   tree type2;
15210
15211   if (! INTEGRAL_TYPE_P (type))
15212     return type;
15213   if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
15214     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15215   if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
15216     return unsignedp ? unsigned_type_node : integer_type_node;
15217   if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
15218     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15219   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
15220     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15221   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
15222     return (unsignedp ? long_long_unsigned_type_node
15223             : long_long_integer_type_node);
15224
15225   type2 = type_for_size (TYPE_PRECISION (type), unsignedp);
15226   if (type2 == NULL_TREE)
15227     return type;
15228
15229   return type2;
15230 }
15231
15232 tree
15233 signed_type (type)
15234      tree type;
15235 {
15236   tree type1 = TYPE_MAIN_VARIANT (type);
15237   ffeinfoKindtype kt;
15238   tree type2;
15239
15240   if (type1 == unsigned_char_type_node || type1 == char_type_node)
15241     return signed_char_type_node;
15242   if (type1 == unsigned_type_node)
15243     return integer_type_node;
15244   if (type1 == short_unsigned_type_node)
15245     return short_integer_type_node;
15246   if (type1 == long_unsigned_type_node)
15247     return long_integer_type_node;
15248   if (type1 == long_long_unsigned_type_node)
15249     return long_long_integer_type_node;
15250 #if 0   /* gcc/c-* files only */
15251   if (type1 == unsigned_intDI_type_node)
15252     return intDI_type_node;
15253   if (type1 == unsigned_intSI_type_node)
15254     return intSI_type_node;
15255   if (type1 == unsigned_intHI_type_node)
15256     return intHI_type_node;
15257   if (type1 == unsigned_intQI_type_node)
15258     return intQI_type_node;
15259 #endif
15260
15261   type2 = type_for_size (TYPE_PRECISION (type1), 0);
15262   if (type2 != NULL_TREE)
15263     return type2;
15264
15265   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15266     {
15267       type2 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15268
15269       if (type1 == type2)
15270         return ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15271     }
15272
15273   return type;
15274 }
15275
15276 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
15277    or validate its data type for an `if' or `while' statement or ?..: exp.
15278
15279    This preparation consists of taking the ordinary
15280    representation of an expression expr and producing a valid tree
15281    boolean expression describing whether expr is nonzero.  We could
15282    simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
15283    but we optimize comparisons, &&, ||, and !.
15284
15285    The resulting type should always be `integer_type_node'.  */
15286
15287 tree
15288 truthvalue_conversion (expr)
15289      tree expr;
15290 {
15291   if (TREE_CODE (expr) == ERROR_MARK)
15292     return expr;
15293
15294 #if 0 /* This appears to be wrong for C++.  */
15295   /* These really should return error_mark_node after 2.4 is stable.
15296      But not all callers handle ERROR_MARK properly.  */
15297   switch (TREE_CODE (TREE_TYPE (expr)))
15298     {
15299     case RECORD_TYPE:
15300       error ("struct type value used where scalar is required");
15301       return integer_zero_node;
15302
15303     case UNION_TYPE:
15304       error ("union type value used where scalar is required");
15305       return integer_zero_node;
15306
15307     case ARRAY_TYPE:
15308       error ("array type value used where scalar is required");
15309       return integer_zero_node;
15310
15311     default:
15312       break;
15313     }
15314 #endif /* 0 */
15315
15316   switch (TREE_CODE (expr))
15317     {
15318       /* It is simpler and generates better code to have only TRUTH_*_EXPR
15319          or comparison expressions as truth values at this level.  */
15320 #if 0
15321     case COMPONENT_REF:
15322       /* A one-bit unsigned bit-field is already acceptable.  */
15323       if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr, 1)))
15324           && TREE_UNSIGNED (TREE_OPERAND (expr, 1)))
15325         return expr;
15326       break;
15327 #endif
15328
15329     case EQ_EXPR:
15330       /* It is simpler and generates better code to have only TRUTH_*_EXPR
15331          or comparison expressions as truth values at this level.  */
15332 #if 0
15333       if (integer_zerop (TREE_OPERAND (expr, 1)))
15334         return build_unary_op (TRUTH_NOT_EXPR, TREE_OPERAND (expr, 0), 0);
15335 #endif
15336     case NE_EXPR: case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR:
15337     case TRUTH_ANDIF_EXPR:
15338     case TRUTH_ORIF_EXPR:
15339     case TRUTH_AND_EXPR:
15340     case TRUTH_OR_EXPR:
15341     case TRUTH_XOR_EXPR:
15342       TREE_TYPE (expr) = integer_type_node;
15343       return expr;
15344
15345     case ERROR_MARK:
15346       return expr;
15347
15348     case INTEGER_CST:
15349       return integer_zerop (expr) ? integer_zero_node : integer_one_node;
15350
15351     case REAL_CST:
15352       return real_zerop (expr) ? integer_zero_node : integer_one_node;
15353
15354     case ADDR_EXPR:
15355       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 0)))
15356         return build (COMPOUND_EXPR, integer_type_node,
15357                       TREE_OPERAND (expr, 0), integer_one_node);
15358       else
15359         return integer_one_node;
15360
15361     case COMPLEX_EXPR:
15362       return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1))
15363                         ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
15364                        integer_type_node,
15365                        truthvalue_conversion (TREE_OPERAND (expr, 0)),
15366                        truthvalue_conversion (TREE_OPERAND (expr, 1)));
15367
15368     case NEGATE_EXPR:
15369     case ABS_EXPR:
15370     case FLOAT_EXPR:
15371     case FFS_EXPR:
15372       /* These don't change whether an object is non-zero or zero.  */
15373       return truthvalue_conversion (TREE_OPERAND (expr, 0));
15374
15375     case LROTATE_EXPR:
15376     case RROTATE_EXPR:
15377       /* These don't change whether an object is zero or non-zero, but
15378          we can't ignore them if their second arg has side-effects.  */
15379       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)))
15380         return build (COMPOUND_EXPR, integer_type_node, TREE_OPERAND (expr, 1),
15381                       truthvalue_conversion (TREE_OPERAND (expr, 0)));
15382       else
15383         return truthvalue_conversion (TREE_OPERAND (expr, 0));
15384
15385     case COND_EXPR:
15386       /* Distribute the conversion into the arms of a COND_EXPR.  */
15387       return fold (build (COND_EXPR, integer_type_node, TREE_OPERAND (expr, 0),
15388                           truthvalue_conversion (TREE_OPERAND (expr, 1)),
15389                           truthvalue_conversion (TREE_OPERAND (expr, 2))));
15390
15391     case CONVERT_EXPR:
15392       /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
15393          since that affects how `default_conversion' will behave.  */
15394       if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE
15395           || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE)
15396         break;
15397       /* fall through... */
15398     case NOP_EXPR:
15399       /* If this is widening the argument, we can ignore it.  */
15400       if (TYPE_PRECISION (TREE_TYPE (expr))
15401           >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0))))
15402         return truthvalue_conversion (TREE_OPERAND (expr, 0));
15403       break;
15404
15405     case MINUS_EXPR:
15406       /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
15407          this case.  */
15408       if (TARGET_FLOAT_FORMAT == IEEE_FLOAT_FORMAT
15409           && TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE)
15410         break;
15411       /* fall through... */
15412     case BIT_XOR_EXPR:
15413       /* This and MINUS_EXPR can be changed into a comparison of the
15414          two objects.  */
15415       if (TREE_TYPE (TREE_OPERAND (expr, 0))
15416           == TREE_TYPE (TREE_OPERAND (expr, 1)))
15417         return ffecom_2 (NE_EXPR, integer_type_node,
15418                          TREE_OPERAND (expr, 0),
15419                          TREE_OPERAND (expr, 1));
15420       return ffecom_2 (NE_EXPR, integer_type_node,
15421                        TREE_OPERAND (expr, 0),
15422                        fold (build1 (NOP_EXPR,
15423                                      TREE_TYPE (TREE_OPERAND (expr, 0)),
15424                                      TREE_OPERAND (expr, 1))));
15425
15426     case BIT_AND_EXPR:
15427       if (integer_onep (TREE_OPERAND (expr, 1)))
15428         return expr;
15429       break;
15430
15431     case MODIFY_EXPR:
15432 #if 0                           /* No such thing in Fortran. */
15433       if (warn_parentheses && C_EXP_ORIGINAL_CODE (expr) == MODIFY_EXPR)
15434         warning ("suggest parentheses around assignment used as truth value");
15435 #endif
15436       break;
15437
15438     default:
15439       break;
15440     }
15441
15442   if (TREE_CODE (TREE_TYPE (expr)) == COMPLEX_TYPE)
15443     return (ffecom_2
15444             ((TREE_SIDE_EFFECTS (expr)
15445               ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
15446              integer_type_node,
15447              truthvalue_conversion (ffecom_1 (REALPART_EXPR,
15448                                               TREE_TYPE (TREE_TYPE (expr)),
15449                                               expr)),
15450              truthvalue_conversion (ffecom_1 (IMAGPART_EXPR,
15451                                               TREE_TYPE (TREE_TYPE (expr)),
15452                                               expr))));
15453
15454   return ffecom_2 (NE_EXPR, integer_type_node,
15455                    expr,
15456                    convert (TREE_TYPE (expr), integer_zero_node));
15457 }
15458
15459 tree
15460 type_for_mode (mode, unsignedp)
15461      enum machine_mode mode;
15462      int unsignedp;
15463 {
15464   int i;
15465   int j;
15466   tree t;
15467
15468   if (mode == TYPE_MODE (integer_type_node))
15469     return unsignedp ? unsigned_type_node : integer_type_node;
15470
15471   if (mode == TYPE_MODE (signed_char_type_node))
15472     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15473
15474   if (mode == TYPE_MODE (short_integer_type_node))
15475     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15476
15477   if (mode == TYPE_MODE (long_integer_type_node))
15478     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15479
15480   if (mode == TYPE_MODE (long_long_integer_type_node))
15481     return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node;
15482
15483 #if HOST_BITS_PER_WIDE_INT >= 64
15484   if (mode == TYPE_MODE (intTI_type_node))
15485     return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
15486 #endif
15487
15488   if (mode == TYPE_MODE (float_type_node))
15489     return float_type_node;
15490
15491   if (mode == TYPE_MODE (double_type_node))
15492     return double_type_node;
15493
15494   if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
15495     return build_pointer_type (char_type_node);
15496
15497   if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
15498     return build_pointer_type (integer_type_node);
15499
15500   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
15501     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
15502       {
15503         if (((t = ffecom_tree_type[i][j]) != NULL_TREE)
15504             && (mode == TYPE_MODE (t)))
15505           {
15506             if ((i == FFEINFO_basictypeINTEGER) && unsignedp)
15507               return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][j];
15508             else
15509               return t;
15510           }
15511       }
15512
15513   return 0;
15514 }
15515
15516 tree
15517 type_for_size (bits, unsignedp)
15518      unsigned bits;
15519      int unsignedp;
15520 {
15521   ffeinfoKindtype kt;
15522   tree type_node;
15523
15524   if (bits == TYPE_PRECISION (integer_type_node))
15525     return unsignedp ? unsigned_type_node : integer_type_node;
15526
15527   if (bits == TYPE_PRECISION (signed_char_type_node))
15528     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15529
15530   if (bits == TYPE_PRECISION (short_integer_type_node))
15531     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15532
15533   if (bits == TYPE_PRECISION (long_integer_type_node))
15534     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15535
15536   if (bits == TYPE_PRECISION (long_long_integer_type_node))
15537     return (unsignedp ? long_long_unsigned_type_node
15538             : long_long_integer_type_node);
15539
15540   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15541     {
15542       type_node = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15543
15544       if ((type_node != NULL_TREE) && (bits == TYPE_PRECISION (type_node)))
15545         return unsignedp ? ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]
15546           : type_node;
15547     }
15548
15549   return 0;
15550 }
15551
15552 tree
15553 unsigned_type (type)
15554      tree type;
15555 {
15556   tree type1 = TYPE_MAIN_VARIANT (type);
15557   ffeinfoKindtype kt;
15558   tree type2;
15559
15560   if (type1 == signed_char_type_node || type1 == char_type_node)
15561     return unsigned_char_type_node;
15562   if (type1 == integer_type_node)
15563     return unsigned_type_node;
15564   if (type1 == short_integer_type_node)
15565     return short_unsigned_type_node;
15566   if (type1 == long_integer_type_node)
15567     return long_unsigned_type_node;
15568   if (type1 == long_long_integer_type_node)
15569     return long_long_unsigned_type_node;
15570 #if 0   /* gcc/c-* files only */
15571   if (type1 == intDI_type_node)
15572     return unsigned_intDI_type_node;
15573   if (type1 == intSI_type_node)
15574     return unsigned_intSI_type_node;
15575   if (type1 == intHI_type_node)
15576     return unsigned_intHI_type_node;
15577   if (type1 == intQI_type_node)
15578     return unsigned_intQI_type_node;
15579 #endif
15580
15581   type2 = type_for_size (TYPE_PRECISION (type1), 1);
15582   if (type2 != NULL_TREE)
15583     return type2;
15584
15585   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15586     {
15587       type2 = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15588
15589       if (type1 == type2)
15590         return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15591     }
15592
15593   return type;
15594 }
15595
15596 void
15597 lang_mark_tree (t)
15598      union tree_node *t ATTRIBUTE_UNUSED;
15599 {
15600   if (TREE_CODE (t) == IDENTIFIER_NODE)
15601     {
15602       struct lang_identifier *i = (struct lang_identifier *) t;
15603       ggc_mark_tree (IDENTIFIER_GLOBAL_VALUE (i));
15604       ggc_mark_tree (IDENTIFIER_LOCAL_VALUE (i));
15605       ggc_mark_tree (IDENTIFIER_LABEL_VALUE (i));
15606     }
15607   else if (TYPE_P (t) && TYPE_LANG_SPECIFIC (t))
15608     ggc_mark (TYPE_LANG_SPECIFIC (t));
15609 }
15610
15611 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
15612 \f
15613 #if FFECOM_GCC_INCLUDE
15614
15615 /* From gcc/cccp.c, the code to handle -I.  */
15616
15617 /* Skip leading "./" from a directory name.
15618    This may yield the empty string, which represents the current directory.  */
15619
15620 static const char *
15621 skip_redundant_dir_prefix (const char *dir)
15622 {
15623   while (dir[0] == '.' && dir[1] == '/')
15624     for (dir += 2; *dir == '/'; dir++)
15625       continue;
15626   if (dir[0] == '.' && !dir[1])
15627     dir++;
15628   return dir;
15629 }
15630
15631 /* The file_name_map structure holds a mapping of file names for a
15632    particular directory.  This mapping is read from the file named
15633    FILE_NAME_MAP_FILE in that directory.  Such a file can be used to
15634    map filenames on a file system with severe filename restrictions,
15635    such as DOS.  The format of the file name map file is just a series
15636    of lines with two tokens on each line.  The first token is the name
15637    to map, and the second token is the actual name to use.  */
15638
15639 struct file_name_map
15640 {
15641   struct file_name_map *map_next;
15642   char *map_from;
15643   char *map_to;
15644 };
15645
15646 #define FILE_NAME_MAP_FILE "header.gcc"
15647
15648 /* Current maximum length of directory names in the search path
15649    for include files.  (Altered as we get more of them.)  */
15650
15651 static int max_include_len = 0;
15652
15653 struct file_name_list
15654   {
15655     struct file_name_list *next;
15656     char *fname;
15657     /* Mapping of file names for this directory.  */
15658     struct file_name_map *name_map;
15659     /* Non-zero if name_map is valid.  */
15660     int got_name_map;
15661   };
15662
15663 static struct file_name_list *include = NULL;   /* First dir to search */
15664 static struct file_name_list *last_include = NULL;      /* Last in chain */
15665
15666 /* I/O buffer structure.
15667    The `fname' field is nonzero for source files and #include files
15668    and for the dummy text used for -D and -U.
15669    It is zero for rescanning results of macro expansion
15670    and for expanding macro arguments.  */
15671 #define INPUT_STACK_MAX 400
15672 static struct file_buf {
15673   const char *fname;
15674   /* Filename specified with #line command.  */
15675   const char *nominal_fname;
15676   /* Record where in the search path this file was found.
15677      For #include_next.  */
15678   struct file_name_list *dir;
15679   ffewhereLine line;
15680   ffewhereColumn column;
15681 } instack[INPUT_STACK_MAX];
15682
15683 static int last_error_tick = 0;    /* Incremented each time we print it.  */
15684 static int input_file_stack_tick = 0;  /* Incremented when status changes.  */
15685
15686 /* Current nesting level of input sources.
15687    `instack[indepth]' is the level currently being read.  */
15688 static int indepth = -1;
15689
15690 typedef struct file_buf FILE_BUF;
15691
15692 typedef unsigned char U_CHAR;
15693
15694 /* table to tell if char can be part of a C identifier. */
15695 U_CHAR is_idchar[256];
15696 /* table to tell if char can be first char of a c identifier. */
15697 U_CHAR is_idstart[256];
15698 /* table to tell if c is horizontal space.  */
15699 U_CHAR is_hor_space[256];
15700 /* table to tell if c is horizontal or vertical space.  */
15701 static U_CHAR is_space[256];
15702
15703 #define SKIP_WHITE_SPACE(p) do { while (is_hor_space[*p]) p++; } while (0)
15704 #define SKIP_ALL_WHITE_SPACE(p) do { while (is_space[*p]) p++; } while (0)
15705
15706 /* Nonzero means -I- has been seen,
15707    so don't look for #include "foo" the source-file directory.  */
15708 static int ignore_srcdir;
15709
15710 #ifndef INCLUDE_LEN_FUDGE
15711 #define INCLUDE_LEN_FUDGE 0
15712 #endif
15713
15714 static void append_include_chain (struct file_name_list *first,
15715                                   struct file_name_list *last);
15716 static FILE *open_include_file (char *filename,
15717                                 struct file_name_list *searchptr);
15718 static void print_containing_files (ffebadSeverity sev);
15719 static const char *skip_redundant_dir_prefix (const char *);
15720 static char *read_filename_string (int ch, FILE *f);
15721 static struct file_name_map *read_name_map (const char *dirname);
15722
15723 /* Append a chain of `struct file_name_list's
15724    to the end of the main include chain.
15725    FIRST is the beginning of the chain to append, and LAST is the end.  */
15726
15727 static void
15728 append_include_chain (first, last)
15729      struct file_name_list *first, *last;
15730 {
15731   struct file_name_list *dir;
15732
15733   if (!first || !last)
15734     return;
15735
15736   if (include == 0)
15737     include = first;
15738   else
15739     last_include->next = first;
15740
15741   for (dir = first; ; dir = dir->next) {
15742     int len = strlen (dir->fname) + INCLUDE_LEN_FUDGE;
15743     if (len > max_include_len)
15744       max_include_len = len;
15745     if (dir == last)
15746       break;
15747   }
15748
15749   last->next = NULL;
15750   last_include = last;
15751 }
15752
15753 /* Try to open include file FILENAME.  SEARCHPTR is the directory
15754    being tried from the include file search path.  This function maps
15755    filenames on file systems based on information read by
15756    read_name_map.  */
15757
15758 static FILE *
15759 open_include_file (filename, searchptr)
15760      char *filename;
15761      struct file_name_list *searchptr;
15762 {
15763   register struct file_name_map *map;
15764   register char *from;
15765   char *p, *dir;
15766
15767   if (searchptr && ! searchptr->got_name_map)
15768     {
15769       searchptr->name_map = read_name_map (searchptr->fname
15770                                            ? searchptr->fname : ".");
15771       searchptr->got_name_map = 1;
15772     }
15773
15774   /* First check the mapping for the directory we are using.  */
15775   if (searchptr && searchptr->name_map)
15776     {
15777       from = filename;
15778       if (searchptr->fname)
15779         from += strlen (searchptr->fname) + 1;
15780       for (map = searchptr->name_map; map; map = map->map_next)
15781         {
15782           if (! strcmp (map->map_from, from))
15783             {
15784               /* Found a match.  */
15785               return fopen (map->map_to, "r");
15786             }
15787         }
15788     }
15789
15790   /* Try to find a mapping file for the particular directory we are
15791      looking in.  Thus #include <sys/types.h> will look up sys/types.h
15792      in /usr/include/header.gcc and look up types.h in
15793      /usr/include/sys/header.gcc.  */
15794   p = strrchr (filename, '/');
15795 #ifdef DIR_SEPARATOR
15796   if (! p) p = strrchr (filename, DIR_SEPARATOR);
15797   else {
15798     char *tmp = strrchr (filename, DIR_SEPARATOR);
15799     if (tmp != NULL && tmp > p) p = tmp;
15800   }
15801 #endif
15802   if (! p)
15803     p = filename;
15804   if (searchptr
15805       && searchptr->fname
15806       && strlen (searchptr->fname) == (size_t) (p - filename)
15807       && ! strncmp (searchptr->fname, filename, (int) (p - filename)))
15808     {
15809       /* FILENAME is in SEARCHPTR, which we've already checked.  */
15810       return fopen (filename, "r");
15811     }
15812
15813   if (p == filename)
15814     {
15815       from = filename;
15816       map = read_name_map (".");
15817     }
15818   else
15819     {
15820       dir = (char *) xmalloc (p - filename + 1);
15821       memcpy (dir, filename, p - filename);
15822       dir[p - filename] = '\0';
15823       from = p + 1;
15824       map = read_name_map (dir);
15825       free (dir);
15826     }
15827   for (; map; map = map->map_next)
15828     if (! strcmp (map->map_from, from))
15829       return fopen (map->map_to, "r");
15830
15831   return fopen (filename, "r");
15832 }
15833
15834 /* Print the file names and line numbers of the #include
15835    commands which led to the current file.  */
15836
15837 static void
15838 print_containing_files (ffebadSeverity sev)
15839 {
15840   FILE_BUF *ip = NULL;
15841   int i;
15842   int first = 1;
15843   const char *str1;
15844   const char *str2;
15845
15846   /* If stack of files hasn't changed since we last printed
15847      this info, don't repeat it.  */
15848   if (last_error_tick == input_file_stack_tick)
15849     return;
15850
15851   for (i = indepth; i >= 0; i--)
15852     if (instack[i].fname != NULL) {
15853       ip = &instack[i];
15854       break;
15855     }
15856
15857   /* Give up if we don't find a source file.  */
15858   if (ip == NULL)
15859     return;
15860
15861   /* Find the other, outer source files.  */
15862   for (i--; i >= 0; i--)
15863     if (instack[i].fname != NULL)
15864       {
15865         ip = &instack[i];
15866         if (first)
15867           {
15868             first = 0;
15869             str1 = "In file included";
15870           }
15871         else
15872           {
15873             str1 = "...          ...";
15874           }
15875
15876         if (i == 1)
15877           str2 = ":";
15878         else
15879           str2 = "";
15880
15881         ffebad_start_msg ("%A from %B at %0%C", sev);
15882         ffebad_here (0, ip->line, ip->column);
15883         ffebad_string (str1);
15884         ffebad_string (ip->nominal_fname);
15885         ffebad_string (str2);
15886         ffebad_finish ();
15887       }
15888
15889   /* Record we have printed the status as of this time.  */
15890   last_error_tick = input_file_stack_tick;
15891 }
15892
15893 /* Read a space delimited string of unlimited length from a stdio
15894    file.  */
15895
15896 static char *
15897 read_filename_string (ch, f)
15898      int ch;
15899      FILE *f;
15900 {
15901   char *alloc, *set;
15902   int len;
15903
15904   len = 20;
15905   set = alloc = xmalloc (len + 1);
15906   if (! is_space[ch])
15907     {
15908       *set++ = ch;
15909       while ((ch = getc (f)) != EOF && ! is_space[ch])
15910         {
15911           if (set - alloc == len)
15912             {
15913               len *= 2;
15914               alloc = xrealloc (alloc, len + 1);
15915               set = alloc + len / 2;
15916             }
15917           *set++ = ch;
15918         }
15919     }
15920   *set = '\0';
15921   ungetc (ch, f);
15922   return alloc;
15923 }
15924
15925 /* Read the file name map file for DIRNAME.  */
15926
15927 static struct file_name_map *
15928 read_name_map (dirname)
15929      const char *dirname;
15930 {
15931   /* This structure holds a linked list of file name maps, one per
15932      directory.  */
15933   struct file_name_map_list
15934     {
15935       struct file_name_map_list *map_list_next;
15936       char *map_list_name;
15937       struct file_name_map *map_list_map;
15938     };
15939   static struct file_name_map_list *map_list;
15940   register struct file_name_map_list *map_list_ptr;
15941   char *name;
15942   FILE *f;
15943   size_t dirlen;
15944   int separator_needed;
15945
15946   dirname = skip_redundant_dir_prefix (dirname);
15947
15948   for (map_list_ptr = map_list; map_list_ptr;
15949        map_list_ptr = map_list_ptr->map_list_next)
15950     if (! strcmp (map_list_ptr->map_list_name, dirname))
15951       return map_list_ptr->map_list_map;
15952
15953   map_list_ptr = ((struct file_name_map_list *)
15954                   xmalloc (sizeof (struct file_name_map_list)));
15955   map_list_ptr->map_list_name = xstrdup (dirname);
15956   map_list_ptr->map_list_map = NULL;
15957
15958   dirlen = strlen (dirname);
15959   separator_needed = dirlen != 0 && dirname[dirlen - 1] != '/';
15960   name = (char *) xmalloc (dirlen + strlen (FILE_NAME_MAP_FILE) + 2);
15961   strcpy (name, dirname);
15962   name[dirlen] = '/';
15963   strcpy (name + dirlen + separator_needed, FILE_NAME_MAP_FILE);
15964   f = fopen (name, "r");
15965   free (name);
15966   if (!f)
15967     map_list_ptr->map_list_map = NULL;
15968   else
15969     {
15970       int ch;
15971
15972       while ((ch = getc (f)) != EOF)
15973         {
15974           char *from, *to;
15975           struct file_name_map *ptr;
15976
15977           if (is_space[ch])
15978             continue;
15979           from = read_filename_string (ch, f);
15980           while ((ch = getc (f)) != EOF && is_hor_space[ch])
15981             ;
15982           to = read_filename_string (ch, f);
15983
15984           ptr = ((struct file_name_map *)
15985                  xmalloc (sizeof (struct file_name_map)));
15986           ptr->map_from = from;
15987
15988           /* Make the real filename absolute.  */
15989           if (*to == '/')
15990             ptr->map_to = to;
15991           else
15992             {
15993               ptr->map_to = xmalloc (dirlen + strlen (to) + 2);
15994               strcpy (ptr->map_to, dirname);
15995               ptr->map_to[dirlen] = '/';
15996               strcpy (ptr->map_to + dirlen + separator_needed, to);
15997               free (to);
15998             }
15999
16000           ptr->map_next = map_list_ptr->map_list_map;
16001           map_list_ptr->map_list_map = ptr;
16002
16003           while ((ch = getc (f)) != '\n')
16004             if (ch == EOF)
16005               break;
16006         }
16007       fclose (f);
16008     }
16009
16010   map_list_ptr->map_list_next = map_list;
16011   map_list = map_list_ptr;
16012
16013   return map_list_ptr->map_list_map;
16014 }
16015
16016 static void
16017 ffecom_file_ (const char *name)
16018 {
16019   FILE_BUF *fp;
16020
16021   /* Do partial setup of input buffer for the sake of generating
16022      early #line directives (when -g is in effect).  */
16023
16024   fp = &instack[++indepth];
16025   memset ((char *) fp, 0, sizeof (FILE_BUF));
16026   if (name == NULL)
16027     name = "";
16028   fp->nominal_fname = fp->fname = name;
16029 }
16030
16031 /* Initialize syntactic classifications of characters.  */
16032
16033 static void
16034 ffecom_initialize_char_syntax_ ()
16035 {
16036   register int i;
16037
16038   /*
16039    * Set up is_idchar and is_idstart tables.  These should be
16040    * faster than saying (is_alpha (c) || c == '_'), etc.
16041    * Set up these things before calling any routines tthat
16042    * refer to them.
16043    */
16044   for (i = 'a'; i <= 'z'; i++) {
16045     is_idchar[i - 'a' + 'A'] = 1;
16046     is_idchar[i] = 1;
16047     is_idstart[i - 'a' + 'A'] = 1;
16048     is_idstart[i] = 1;
16049   }
16050   for (i = '0'; i <= '9'; i++)
16051     is_idchar[i] = 1;
16052   is_idchar['_'] = 1;
16053   is_idstart['_'] = 1;
16054
16055   /* horizontal space table */
16056   is_hor_space[' '] = 1;
16057   is_hor_space['\t'] = 1;
16058   is_hor_space['\v'] = 1;
16059   is_hor_space['\f'] = 1;
16060   is_hor_space['\r'] = 1;
16061
16062   is_space[' '] = 1;
16063   is_space['\t'] = 1;
16064   is_space['\v'] = 1;
16065   is_space['\f'] = 1;
16066   is_space['\n'] = 1;
16067   is_space['\r'] = 1;
16068 }
16069
16070 static void
16071 ffecom_close_include_ (FILE *f)
16072 {
16073   fclose (f);
16074
16075   indepth--;
16076   input_file_stack_tick++;
16077
16078   ffewhere_line_kill (instack[indepth].line);
16079   ffewhere_column_kill (instack[indepth].column);
16080 }
16081
16082 static int
16083 ffecom_decode_include_option_ (char *spec)
16084 {
16085   struct file_name_list *dirtmp;
16086
16087   if (! ignore_srcdir && !strcmp (spec, "-"))
16088     ignore_srcdir = 1;
16089   else
16090     {
16091       dirtmp = (struct file_name_list *)
16092         xmalloc (sizeof (struct file_name_list));
16093       dirtmp->next = 0;         /* New one goes on the end */
16094       if (spec[0] != 0)
16095         dirtmp->fname = spec;
16096       else
16097         fatal ("Directory name must immediately follow -I option with no intervening spaces, as in `-Idir', not `-I dir'");
16098       dirtmp->got_name_map = 0;
16099       append_include_chain (dirtmp, dirtmp);
16100     }
16101   return 1;
16102 }
16103
16104 /* Open INCLUDEd file.  */
16105
16106 static FILE *
16107 ffecom_open_include_ (char *name, ffewhereLine l, ffewhereColumn c)
16108 {
16109   char *fbeg = name;
16110   size_t flen = strlen (fbeg);
16111   struct file_name_list *search_start = include; /* Chain of dirs to search */
16112   struct file_name_list dsp[1]; /* First in chain, if #include "..." */
16113   struct file_name_list *searchptr = 0;
16114   char *fname;          /* Dynamically allocated fname buffer */
16115   FILE *f;
16116   FILE_BUF *fp;
16117
16118   if (flen == 0)
16119     return NULL;
16120
16121   dsp[0].fname = NULL;
16122
16123   /* If -I- was specified, don't search current dir, only spec'd ones. */
16124   if (!ignore_srcdir)
16125     {
16126       for (fp = &instack[indepth]; fp >= instack; fp--)
16127         {
16128           int n;
16129           char *ep;
16130           const char *nam;
16131
16132           if ((nam = fp->nominal_fname) != NULL)
16133             {
16134               /* Found a named file.  Figure out dir of the file,
16135                  and put it in front of the search list.  */
16136               dsp[0].next = search_start;
16137               search_start = dsp;
16138 #ifndef VMS
16139               ep = strrchr (nam, '/');
16140 #ifdef DIR_SEPARATOR
16141             if (ep == NULL) ep = strrchr (nam, DIR_SEPARATOR);
16142             else {
16143               char *tmp = strrchr (nam, DIR_SEPARATOR);
16144               if (tmp != NULL && tmp > ep) ep = tmp;
16145             }
16146 #endif
16147 #else                           /* VMS */
16148               ep = strrchr (nam, ']');
16149               if (ep == NULL) ep = strrchr (nam, '>');
16150               if (ep == NULL) ep = strrchr (nam, ':');
16151               if (ep != NULL) ep++;
16152 #endif                          /* VMS */
16153               if (ep != NULL)
16154                 {
16155                   n = ep - nam;
16156                   dsp[0].fname = (char *) xmalloc (n + 1);
16157                   strncpy (dsp[0].fname, nam, n);
16158                   dsp[0].fname[n] = '\0';
16159                   if (n + INCLUDE_LEN_FUDGE > max_include_len)
16160                     max_include_len = n + INCLUDE_LEN_FUDGE;
16161                 }
16162               else
16163                 dsp[0].fname = NULL; /* Current directory */
16164               dsp[0].got_name_map = 0;
16165               break;
16166             }
16167         }
16168     }
16169
16170   /* Allocate this permanently, because it gets stored in the definitions
16171      of macros.  */
16172   fname = xmalloc (max_include_len + flen + 4);
16173   /* + 2 above for slash and terminating null.  */
16174   /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
16175      for g77 yet).  */
16176
16177   /* If specified file name is absolute, just open it.  */
16178
16179   if (*fbeg == '/'
16180 #ifdef DIR_SEPARATOR
16181       || *fbeg == DIR_SEPARATOR
16182 #endif
16183       )
16184     {
16185       strncpy (fname, (char *) fbeg, flen);
16186       fname[flen] = 0;
16187       f = open_include_file (fname, NULL_PTR);
16188     }
16189   else
16190     {
16191       f = NULL;
16192
16193       /* Search directory path, trying to open the file.
16194          Copy each filename tried into FNAME.  */
16195
16196       for (searchptr = search_start; searchptr; searchptr = searchptr->next)
16197         {
16198           if (searchptr->fname)
16199             {
16200               /* The empty string in a search path is ignored.
16201                  This makes it possible to turn off entirely
16202                  a standard piece of the list.  */
16203               if (searchptr->fname[0] == 0)
16204                 continue;
16205               strcpy (fname, skip_redundant_dir_prefix (searchptr->fname));
16206               if (fname[0] && fname[strlen (fname) - 1] != '/')
16207                 strcat (fname, "/");
16208               fname[strlen (fname) + flen] = 0;
16209             }
16210           else
16211             fname[0] = 0;
16212
16213           strncat (fname, fbeg, flen);
16214 #ifdef VMS
16215           /* Change this 1/2 Unix 1/2 VMS file specification into a
16216              full VMS file specification */
16217           if (searchptr->fname && (searchptr->fname[0] != 0))
16218             {
16219               /* Fix up the filename */
16220               hack_vms_include_specification (fname);
16221             }
16222           else
16223             {
16224               /* This is a normal VMS filespec, so use it unchanged.  */
16225               strncpy (fname, (char *) fbeg, flen);
16226               fname[flen] = 0;
16227 #if 0   /* Not for g77.  */
16228               /* if it's '#include filename', add the missing .h */
16229               if (strchr (fname, '.') == NULL)
16230                 strcat (fname, ".h");
16231 #endif
16232             }
16233 #endif /* VMS */
16234           f = open_include_file (fname, searchptr);
16235 #ifdef EACCES
16236           if (f == NULL && errno == EACCES)
16237             {
16238               print_containing_files (FFEBAD_severityWARNING);
16239               ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
16240                                 FFEBAD_severityWARNING);
16241               ffebad_string (fname);
16242               ffebad_here (0, l, c);
16243               ffebad_finish ();
16244             }
16245 #endif
16246           if (f != NULL)
16247             break;
16248         }
16249     }
16250
16251   if (f == NULL)
16252     {
16253       /* A file that was not found.  */
16254
16255       strncpy (fname, (char *) fbeg, flen);
16256       fname[flen] = 0;
16257       print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE));
16258       ffebad_start (FFEBAD_OPEN_INCLUDE);
16259       ffebad_here (0, l, c);
16260       ffebad_string (fname);
16261       ffebad_finish ();
16262     }
16263
16264   if (dsp[0].fname != NULL)
16265     free (dsp[0].fname);
16266
16267   if (f == NULL)
16268     return NULL;
16269
16270   if (indepth >= (INPUT_STACK_MAX - 1))
16271     {
16272       print_containing_files (FFEBAD_severityFATAL);
16273       ffebad_start_msg ("At %0, INCLUDE nesting too deep",
16274                         FFEBAD_severityFATAL);
16275       ffebad_string (fname);
16276       ffebad_here (0, l, c);
16277       ffebad_finish ();
16278       return NULL;
16279     }
16280
16281   instack[indepth].line = ffewhere_line_use (l);
16282   instack[indepth].column = ffewhere_column_use (c);
16283
16284   fp = &instack[indepth + 1];
16285   memset ((char *) fp, 0, sizeof (FILE_BUF));
16286   fp->nominal_fname = fp->fname = fname;
16287   fp->dir = searchptr;
16288
16289   indepth++;
16290   input_file_stack_tick++;
16291
16292   return f;
16293 }
16294 #endif  /* FFECOM_GCC_INCLUDE */
16295
16296 /**INDENT* (Do not reformat this comment even with -fca option.)
16297    Data-gathering files: Given the source file listed below, compiled with
16298    f2c I obtained the output file listed after that, and from the output
16299    file I derived the above code.
16300
16301 -------- (begin input file to f2c)
16302         implicit none
16303         character*10 A1,A2
16304         complex C1,C2
16305         integer I1,I2
16306         real R1,R2
16307         double precision D1,D2
16308 C
16309         call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
16310 c /
16311         call fooI(I1/I2)
16312         call fooR(R1/I1)
16313         call fooD(D1/I1)
16314         call fooC(C1/I1)
16315         call fooR(R1/R2)
16316         call fooD(R1/D1)
16317         call fooD(D1/D2)
16318         call fooD(D1/R1)
16319         call fooC(C1/C2)
16320         call fooC(C1/R1)
16321         call fooZ(C1/D1)
16322 c **
16323         call fooI(I1**I2)
16324         call fooR(R1**I1)
16325         call fooD(D1**I1)
16326         call fooC(C1**I1)
16327         call fooR(R1**R2)
16328         call fooD(R1**D1)
16329         call fooD(D1**D2)
16330         call fooD(D1**R1)
16331         call fooC(C1**C2)
16332         call fooC(C1**R1)
16333         call fooZ(C1**D1)
16334 c FFEINTRIN_impABS
16335         call fooR(ABS(R1))
16336 c FFEINTRIN_impACOS
16337         call fooR(ACOS(R1))
16338 c FFEINTRIN_impAIMAG
16339         call fooR(AIMAG(C1))
16340 c FFEINTRIN_impAINT
16341         call fooR(AINT(R1))
16342 c FFEINTRIN_impALOG
16343         call fooR(ALOG(R1))
16344 c FFEINTRIN_impALOG10
16345         call fooR(ALOG10(R1))
16346 c FFEINTRIN_impAMAX0
16347         call fooR(AMAX0(I1,I2))
16348 c FFEINTRIN_impAMAX1
16349         call fooR(AMAX1(R1,R2))
16350 c FFEINTRIN_impAMIN0
16351         call fooR(AMIN0(I1,I2))
16352 c FFEINTRIN_impAMIN1
16353         call fooR(AMIN1(R1,R2))
16354 c FFEINTRIN_impAMOD
16355         call fooR(AMOD(R1,R2))
16356 c FFEINTRIN_impANINT
16357         call fooR(ANINT(R1))
16358 c FFEINTRIN_impASIN
16359         call fooR(ASIN(R1))
16360 c FFEINTRIN_impATAN
16361         call fooR(ATAN(R1))
16362 c FFEINTRIN_impATAN2
16363         call fooR(ATAN2(R1,R2))
16364 c FFEINTRIN_impCABS
16365         call fooR(CABS(C1))
16366 c FFEINTRIN_impCCOS
16367         call fooC(CCOS(C1))
16368 c FFEINTRIN_impCEXP
16369         call fooC(CEXP(C1))
16370 c FFEINTRIN_impCHAR
16371         call fooA(CHAR(I1))
16372 c FFEINTRIN_impCLOG
16373         call fooC(CLOG(C1))
16374 c FFEINTRIN_impCONJG
16375         call fooC(CONJG(C1))
16376 c FFEINTRIN_impCOS
16377         call fooR(COS(R1))
16378 c FFEINTRIN_impCOSH
16379         call fooR(COSH(R1))
16380 c FFEINTRIN_impCSIN
16381         call fooC(CSIN(C1))
16382 c FFEINTRIN_impCSQRT
16383         call fooC(CSQRT(C1))
16384 c FFEINTRIN_impDABS
16385         call fooD(DABS(D1))
16386 c FFEINTRIN_impDACOS
16387         call fooD(DACOS(D1))
16388 c FFEINTRIN_impDASIN
16389         call fooD(DASIN(D1))
16390 c FFEINTRIN_impDATAN
16391         call fooD(DATAN(D1))
16392 c FFEINTRIN_impDATAN2
16393         call fooD(DATAN2(D1,D2))
16394 c FFEINTRIN_impDCOS
16395         call fooD(DCOS(D1))
16396 c FFEINTRIN_impDCOSH
16397         call fooD(DCOSH(D1))
16398 c FFEINTRIN_impDDIM
16399         call fooD(DDIM(D1,D2))
16400 c FFEINTRIN_impDEXP
16401         call fooD(DEXP(D1))
16402 c FFEINTRIN_impDIM
16403         call fooR(DIM(R1,R2))
16404 c FFEINTRIN_impDINT
16405         call fooD(DINT(D1))
16406 c FFEINTRIN_impDLOG
16407         call fooD(DLOG(D1))
16408 c FFEINTRIN_impDLOG10
16409         call fooD(DLOG10(D1))
16410 c FFEINTRIN_impDMAX1
16411         call fooD(DMAX1(D1,D2))
16412 c FFEINTRIN_impDMIN1
16413         call fooD(DMIN1(D1,D2))
16414 c FFEINTRIN_impDMOD
16415         call fooD(DMOD(D1,D2))
16416 c FFEINTRIN_impDNINT
16417         call fooD(DNINT(D1))
16418 c FFEINTRIN_impDPROD
16419         call fooD(DPROD(R1,R2))
16420 c FFEINTRIN_impDSIGN
16421         call fooD(DSIGN(D1,D2))
16422 c FFEINTRIN_impDSIN
16423         call fooD(DSIN(D1))
16424 c FFEINTRIN_impDSINH
16425         call fooD(DSINH(D1))
16426 c FFEINTRIN_impDSQRT
16427         call fooD(DSQRT(D1))
16428 c FFEINTRIN_impDTAN
16429         call fooD(DTAN(D1))
16430 c FFEINTRIN_impDTANH
16431         call fooD(DTANH(D1))
16432 c FFEINTRIN_impEXP
16433         call fooR(EXP(R1))
16434 c FFEINTRIN_impIABS
16435         call fooI(IABS(I1))
16436 c FFEINTRIN_impICHAR
16437         call fooI(ICHAR(A1))
16438 c FFEINTRIN_impIDIM
16439         call fooI(IDIM(I1,I2))
16440 c FFEINTRIN_impIDNINT
16441         call fooI(IDNINT(D1))
16442 c FFEINTRIN_impINDEX
16443         call fooI(INDEX(A1,A2))
16444 c FFEINTRIN_impISIGN
16445         call fooI(ISIGN(I1,I2))
16446 c FFEINTRIN_impLEN
16447         call fooI(LEN(A1))
16448 c FFEINTRIN_impLGE
16449         call fooL(LGE(A1,A2))
16450 c FFEINTRIN_impLGT
16451         call fooL(LGT(A1,A2))
16452 c FFEINTRIN_impLLE
16453         call fooL(LLE(A1,A2))
16454 c FFEINTRIN_impLLT
16455         call fooL(LLT(A1,A2))
16456 c FFEINTRIN_impMAX0
16457         call fooI(MAX0(I1,I2))
16458 c FFEINTRIN_impMAX1
16459         call fooI(MAX1(R1,R2))
16460 c FFEINTRIN_impMIN0
16461         call fooI(MIN0(I1,I2))
16462 c FFEINTRIN_impMIN1
16463         call fooI(MIN1(R1,R2))
16464 c FFEINTRIN_impMOD
16465         call fooI(MOD(I1,I2))
16466 c FFEINTRIN_impNINT
16467         call fooI(NINT(R1))
16468 c FFEINTRIN_impSIGN
16469         call fooR(SIGN(R1,R2))
16470 c FFEINTRIN_impSIN
16471         call fooR(SIN(R1))
16472 c FFEINTRIN_impSINH
16473         call fooR(SINH(R1))
16474 c FFEINTRIN_impSQRT
16475         call fooR(SQRT(R1))
16476 c FFEINTRIN_impTAN
16477         call fooR(TAN(R1))
16478 c FFEINTRIN_impTANH
16479         call fooR(TANH(R1))
16480 c FFEINTRIN_imp_CMPLX_C
16481         call fooC(cmplx(C1,C2))
16482 c FFEINTRIN_imp_CMPLX_D
16483         call fooZ(cmplx(D1,D2))
16484 c FFEINTRIN_imp_CMPLX_I
16485         call fooC(cmplx(I1,I2))
16486 c FFEINTRIN_imp_CMPLX_R
16487         call fooC(cmplx(R1,R2))
16488 c FFEINTRIN_imp_DBLE_C
16489         call fooD(dble(C1))
16490 c FFEINTRIN_imp_DBLE_D
16491         call fooD(dble(D1))
16492 c FFEINTRIN_imp_DBLE_I
16493         call fooD(dble(I1))
16494 c FFEINTRIN_imp_DBLE_R
16495         call fooD(dble(R1))
16496 c FFEINTRIN_imp_INT_C
16497         call fooI(int(C1))
16498 c FFEINTRIN_imp_INT_D
16499         call fooI(int(D1))
16500 c FFEINTRIN_imp_INT_I
16501         call fooI(int(I1))
16502 c FFEINTRIN_imp_INT_R
16503         call fooI(int(R1))
16504 c FFEINTRIN_imp_REAL_C
16505         call fooR(real(C1))
16506 c FFEINTRIN_imp_REAL_D
16507         call fooR(real(D1))
16508 c FFEINTRIN_imp_REAL_I
16509         call fooR(real(I1))
16510 c FFEINTRIN_imp_REAL_R
16511         call fooR(real(R1))
16512 c
16513 c FFEINTRIN_imp_INT_D:
16514 c
16515 c FFEINTRIN_specIDINT
16516         call fooI(IDINT(D1))
16517 c
16518 c FFEINTRIN_imp_INT_R:
16519 c
16520 c FFEINTRIN_specIFIX
16521         call fooI(IFIX(R1))
16522 c FFEINTRIN_specINT
16523         call fooI(INT(R1))
16524 c
16525 c FFEINTRIN_imp_REAL_D:
16526 c
16527 c FFEINTRIN_specSNGL
16528         call fooR(SNGL(D1))
16529 c
16530 c FFEINTRIN_imp_REAL_I:
16531 c
16532 c FFEINTRIN_specFLOAT
16533         call fooR(FLOAT(I1))
16534 c FFEINTRIN_specREAL
16535         call fooR(REAL(I1))
16536 c
16537         end
16538 -------- (end input file to f2c)
16539
16540 -------- (begin output from providing above input file as input to:
16541 --------  `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
16542 --------     -e "s:^#.*$::g"')
16543
16544 //  -- translated by f2c (version 19950223).
16545    You must link the resulting object file with the libraries:
16546         -lf2c -lm   (in that order)
16547 //
16548
16549
16550 // f2c.h  --  Standard Fortran to C header file //
16551
16552 ///  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
16553
16554         - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
16555
16556
16557
16558
16559 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
16560 // we assume short, float are OK //
16561 typedef long int // long int // integer;
16562 typedef char *address;
16563 typedef short int shortint;
16564 typedef float real;
16565 typedef double doublereal;
16566 typedef struct { real r, i; } complex;
16567 typedef struct { doublereal r, i; } doublecomplex;
16568 typedef long int // long int // logical;
16569 typedef short int shortlogical;
16570 typedef char logical1;
16571 typedef char integer1;
16572 // typedef long long longint; // // system-dependent //
16573
16574
16575
16576
16577 // Extern is for use with -E //
16578
16579
16580
16581
16582 // I/O stuff //
16583
16584
16585
16586
16587
16588
16589
16590
16591 typedef long int // int or long int // flag;
16592 typedef long int // int or long int // ftnlen;
16593 typedef long int // int or long int // ftnint;
16594
16595
16596 //external read, write//
16597 typedef struct
16598 {       flag cierr;
16599         ftnint ciunit;
16600         flag ciend;
16601         char *cifmt;
16602         ftnint cirec;
16603 } cilist;
16604
16605 //internal read, write//
16606 typedef struct
16607 {       flag icierr;
16608         char *iciunit;
16609         flag iciend;
16610         char *icifmt;
16611         ftnint icirlen;
16612         ftnint icirnum;
16613 } icilist;
16614
16615 //open//
16616 typedef struct
16617 {       flag oerr;
16618         ftnint ounit;
16619         char *ofnm;
16620         ftnlen ofnmlen;
16621         char *osta;
16622         char *oacc;
16623         char *ofm;
16624         ftnint orl;
16625         char *oblnk;
16626 } olist;
16627
16628 //close//
16629 typedef struct
16630 {       flag cerr;
16631         ftnint cunit;
16632         char *csta;
16633 } cllist;
16634
16635 //rewind, backspace, endfile//
16636 typedef struct
16637 {       flag aerr;
16638         ftnint aunit;
16639 } alist;
16640
16641 // inquire //
16642 typedef struct
16643 {       flag inerr;
16644         ftnint inunit;
16645         char *infile;
16646         ftnlen infilen;
16647         ftnint  *inex;  //parameters in standard's order//
16648         ftnint  *inopen;
16649         ftnint  *innum;
16650         ftnint  *innamed;
16651         char    *inname;
16652         ftnlen  innamlen;
16653         char    *inacc;
16654         ftnlen  inacclen;
16655         char    *inseq;
16656         ftnlen  inseqlen;
16657         char    *indir;
16658         ftnlen  indirlen;
16659         char    *infmt;
16660         ftnlen  infmtlen;
16661         char    *inform;
16662         ftnint  informlen;
16663         char    *inunf;
16664         ftnlen  inunflen;
16665         ftnint  *inrecl;
16666         ftnint  *innrec;
16667         char    *inblank;
16668         ftnlen  inblanklen;
16669 } inlist;
16670
16671
16672
16673 union Multitype {       // for multiple entry points //
16674         integer1 g;
16675         shortint h;
16676         integer i;
16677         // longint j; //
16678         real r;
16679         doublereal d;
16680         complex c;
16681         doublecomplex z;
16682         };
16683
16684 typedef union Multitype Multitype;
16685
16686 typedef long Long;      // No longer used; formerly in Namelist //
16687
16688 struct Vardesc {        // for Namelist //
16689         char *name;
16690         char *addr;
16691         ftnlen *dims;
16692         int  type;
16693         };
16694 typedef struct Vardesc Vardesc;
16695
16696 struct Namelist {
16697         char *name;
16698         Vardesc **vars;
16699         int nvars;
16700         };
16701 typedef struct Namelist Namelist;
16702
16703
16704
16705
16706
16707
16708
16709
16710 // procedure parameter types for -A and -C++ //
16711
16712
16713
16714
16715 typedef int // Unknown procedure type // (*U_fp)();
16716 typedef shortint (*J_fp)();
16717 typedef integer (*I_fp)();
16718 typedef real (*R_fp)();
16719 typedef doublereal (*D_fp)(), (*E_fp)();
16720 typedef // Complex // void  (*C_fp)();
16721 typedef // Double Complex // void  (*Z_fp)();
16722 typedef logical (*L_fp)();
16723 typedef shortlogical (*K_fp)();
16724 typedef // Character // void  (*H_fp)();
16725 typedef // Subroutine // int (*S_fp)();
16726
16727 // E_fp is for real functions when -R is not specified //
16728 typedef void  C_f;      // complex function //
16729 typedef void  H_f;      // character function //
16730 typedef void  Z_f;      // double complex function //
16731 typedef doublereal E_f; // real function with -R not specified //
16732
16733 // undef any lower-case symbols that your C compiler predefines, e.g.: //
16734
16735
16736 // (No such symbols should be defined in a strict ANSI C compiler.
16737    We can avoid trouble with f2c-translated code by using
16738    gcc -ansi [-traditional].) //
16739
16740
16741
16742
16743
16744
16745
16746
16747
16748
16749
16750
16751
16752
16753
16754
16755
16756
16757
16758
16759
16760
16761
16762 // Main program // MAIN__()
16763 {
16764     // System generated locals //
16765     integer i__1;
16766     real r__1, r__2;
16767     doublereal d__1, d__2;
16768     complex q__1;
16769     doublecomplex z__1, z__2, z__3;
16770     logical L__1;
16771     char ch__1[1];
16772
16773     // Builtin functions //
16774     void c_div();
16775     integer pow_ii();
16776     double pow_ri(), pow_di();
16777     void pow_ci();
16778     double pow_dd();
16779     void pow_zz();
16780     double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
16781             asin(), atan(), atan2(), c_abs();
16782     void c_cos(), c_exp(), c_log(), r_cnjg();
16783     double cos(), cosh();
16784     void c_sin(), c_sqrt();
16785     double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
16786             d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
16787     integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
16788     logical l_ge(), l_gt(), l_le(), l_lt();
16789     integer i_nint();
16790     double r_sign();
16791
16792     // Local variables //
16793     extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
16794             fool_(), fooz_(), getem_();
16795     static char a1[10], a2[10];
16796     static complex c1, c2;
16797     static doublereal d1, d2;
16798     static integer i1, i2;
16799     static real r1, r2;
16800
16801
16802     getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
16803 // / //
16804     i__1 = i1 / i2;
16805     fooi_(&i__1);
16806     r__1 = r1 / i1;
16807     foor_(&r__1);
16808     d__1 = d1 / i1;
16809     food_(&d__1);
16810     d__1 = (doublereal) i1;
16811     q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
16812     fooc_(&q__1);
16813     r__1 = r1 / r2;
16814     foor_(&r__1);
16815     d__1 = r1 / d1;
16816     food_(&d__1);
16817     d__1 = d1 / d2;
16818     food_(&d__1);
16819     d__1 = d1 / r1;
16820     food_(&d__1);
16821     c_div(&q__1, &c1, &c2);
16822     fooc_(&q__1);
16823     q__1.r = c1.r / r1, q__1.i = c1.i / r1;
16824     fooc_(&q__1);
16825     z__1.r = c1.r / d1, z__1.i = c1.i / d1;
16826     fooz_(&z__1);
16827 // ** //
16828     i__1 = pow_ii(&i1, &i2);
16829     fooi_(&i__1);
16830     r__1 = pow_ri(&r1, &i1);
16831     foor_(&r__1);
16832     d__1 = pow_di(&d1, &i1);
16833     food_(&d__1);
16834     pow_ci(&q__1, &c1, &i1);
16835     fooc_(&q__1);
16836     d__1 = (doublereal) r1;
16837     d__2 = (doublereal) r2;
16838     r__1 = pow_dd(&d__1, &d__2);
16839     foor_(&r__1);
16840     d__2 = (doublereal) r1;
16841     d__1 = pow_dd(&d__2, &d1);
16842     food_(&d__1);
16843     d__1 = pow_dd(&d1, &d2);
16844     food_(&d__1);
16845     d__2 = (doublereal) r1;
16846     d__1 = pow_dd(&d1, &d__2);
16847     food_(&d__1);
16848     z__2.r = c1.r, z__2.i = c1.i;
16849     z__3.r = c2.r, z__3.i = c2.i;
16850     pow_zz(&z__1, &z__2, &z__3);
16851     q__1.r = z__1.r, q__1.i = z__1.i;
16852     fooc_(&q__1);
16853     z__2.r = c1.r, z__2.i = c1.i;
16854     z__3.r = r1, z__3.i = 0.;
16855     pow_zz(&z__1, &z__2, &z__3);
16856     q__1.r = z__1.r, q__1.i = z__1.i;
16857     fooc_(&q__1);
16858     z__2.r = c1.r, z__2.i = c1.i;
16859     z__3.r = d1, z__3.i = 0.;
16860     pow_zz(&z__1, &z__2, &z__3);
16861     fooz_(&z__1);
16862 // FFEINTRIN_impABS //
16863     r__1 = (doublereal)((  r1  ) >= 0 ? (  r1  ) : -(  r1  ))  ;
16864     foor_(&r__1);
16865 // FFEINTRIN_impACOS //
16866     r__1 = acos(r1);
16867     foor_(&r__1);
16868 // FFEINTRIN_impAIMAG //
16869     r__1 = r_imag(&c1);
16870     foor_(&r__1);
16871 // FFEINTRIN_impAINT //
16872     r__1 = r_int(&r1);
16873     foor_(&r__1);
16874 // FFEINTRIN_impALOG //
16875     r__1 = log(r1);
16876     foor_(&r__1);
16877 // FFEINTRIN_impALOG10 //
16878     r__1 = r_lg10(&r1);
16879     foor_(&r__1);
16880 // FFEINTRIN_impAMAX0 //
16881     r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16882     foor_(&r__1);
16883 // FFEINTRIN_impAMAX1 //
16884     r__1 = (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16885     foor_(&r__1);
16886 // FFEINTRIN_impAMIN0 //
16887     r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16888     foor_(&r__1);
16889 // FFEINTRIN_impAMIN1 //
16890     r__1 = (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16891     foor_(&r__1);
16892 // FFEINTRIN_impAMOD //
16893     r__1 = r_mod(&r1, &r2);
16894     foor_(&r__1);
16895 // FFEINTRIN_impANINT //
16896     r__1 = r_nint(&r1);
16897     foor_(&r__1);
16898 // FFEINTRIN_impASIN //
16899     r__1 = asin(r1);
16900     foor_(&r__1);
16901 // FFEINTRIN_impATAN //
16902     r__1 = atan(r1);
16903     foor_(&r__1);
16904 // FFEINTRIN_impATAN2 //
16905     r__1 = atan2(r1, r2);
16906     foor_(&r__1);
16907 // FFEINTRIN_impCABS //
16908     r__1 = c_abs(&c1);
16909     foor_(&r__1);
16910 // FFEINTRIN_impCCOS //
16911     c_cos(&q__1, &c1);
16912     fooc_(&q__1);
16913 // FFEINTRIN_impCEXP //
16914     c_exp(&q__1, &c1);
16915     fooc_(&q__1);
16916 // FFEINTRIN_impCHAR //
16917     *(unsigned char *)&ch__1[0] = i1;
16918     fooa_(ch__1, 1L);
16919 // FFEINTRIN_impCLOG //
16920     c_log(&q__1, &c1);
16921     fooc_(&q__1);
16922 // FFEINTRIN_impCONJG //
16923     r_cnjg(&q__1, &c1);
16924     fooc_(&q__1);
16925 // FFEINTRIN_impCOS //
16926     r__1 = cos(r1);
16927     foor_(&r__1);
16928 // FFEINTRIN_impCOSH //
16929     r__1 = cosh(r1);
16930     foor_(&r__1);
16931 // FFEINTRIN_impCSIN //
16932     c_sin(&q__1, &c1);
16933     fooc_(&q__1);
16934 // FFEINTRIN_impCSQRT //
16935     c_sqrt(&q__1, &c1);
16936     fooc_(&q__1);
16937 // FFEINTRIN_impDABS //
16938     d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
16939     food_(&d__1);
16940 // FFEINTRIN_impDACOS //
16941     d__1 = acos(d1);
16942     food_(&d__1);
16943 // FFEINTRIN_impDASIN //
16944     d__1 = asin(d1);
16945     food_(&d__1);
16946 // FFEINTRIN_impDATAN //
16947     d__1 = atan(d1);
16948     food_(&d__1);
16949 // FFEINTRIN_impDATAN2 //
16950     d__1 = atan2(d1, d2);
16951     food_(&d__1);
16952 // FFEINTRIN_impDCOS //
16953     d__1 = cos(d1);
16954     food_(&d__1);
16955 // FFEINTRIN_impDCOSH //
16956     d__1 = cosh(d1);
16957     food_(&d__1);
16958 // FFEINTRIN_impDDIM //
16959     d__1 = d_dim(&d1, &d2);
16960     food_(&d__1);
16961 // FFEINTRIN_impDEXP //
16962     d__1 = exp(d1);
16963     food_(&d__1);
16964 // FFEINTRIN_impDIM //
16965     r__1 = r_dim(&r1, &r2);
16966     foor_(&r__1);
16967 // FFEINTRIN_impDINT //
16968     d__1 = d_int(&d1);
16969     food_(&d__1);
16970 // FFEINTRIN_impDLOG //
16971     d__1 = log(d1);
16972     food_(&d__1);
16973 // FFEINTRIN_impDLOG10 //
16974     d__1 = d_lg10(&d1);
16975     food_(&d__1);
16976 // FFEINTRIN_impDMAX1 //
16977     d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
16978     food_(&d__1);
16979 // FFEINTRIN_impDMIN1 //
16980     d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
16981     food_(&d__1);
16982 // FFEINTRIN_impDMOD //
16983     d__1 = d_mod(&d1, &d2);
16984     food_(&d__1);
16985 // FFEINTRIN_impDNINT //
16986     d__1 = d_nint(&d1);
16987     food_(&d__1);
16988 // FFEINTRIN_impDPROD //
16989     d__1 = (doublereal) r1 * r2;
16990     food_(&d__1);
16991 // FFEINTRIN_impDSIGN //
16992     d__1 = d_sign(&d1, &d2);
16993     food_(&d__1);
16994 // FFEINTRIN_impDSIN //
16995     d__1 = sin(d1);
16996     food_(&d__1);
16997 // FFEINTRIN_impDSINH //
16998     d__1 = sinh(d1);
16999     food_(&d__1);
17000 // FFEINTRIN_impDSQRT //
17001     d__1 = sqrt(d1);
17002     food_(&d__1);
17003 // FFEINTRIN_impDTAN //
17004     d__1 = tan(d1);
17005     food_(&d__1);
17006 // FFEINTRIN_impDTANH //
17007     d__1 = tanh(d1);
17008     food_(&d__1);
17009 // FFEINTRIN_impEXP //
17010     r__1 = exp(r1);
17011     foor_(&r__1);
17012 // FFEINTRIN_impIABS //
17013     i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
17014     fooi_(&i__1);
17015 // FFEINTRIN_impICHAR //
17016     i__1 = *(unsigned char *)a1;
17017     fooi_(&i__1);
17018 // FFEINTRIN_impIDIM //
17019     i__1 = i_dim(&i1, &i2);
17020     fooi_(&i__1);
17021 // FFEINTRIN_impIDNINT //
17022     i__1 = i_dnnt(&d1);
17023     fooi_(&i__1);
17024 // FFEINTRIN_impINDEX //
17025     i__1 = i_indx(a1, a2, 10L, 10L);
17026     fooi_(&i__1);
17027 // FFEINTRIN_impISIGN //
17028     i__1 = i_sign(&i1, &i2);
17029     fooi_(&i__1);
17030 // FFEINTRIN_impLEN //
17031     i__1 = i_len(a1, 10L);
17032     fooi_(&i__1);
17033 // FFEINTRIN_impLGE //
17034     L__1 = l_ge(a1, a2, 10L, 10L);
17035     fool_(&L__1);
17036 // FFEINTRIN_impLGT //
17037     L__1 = l_gt(a1, a2, 10L, 10L);
17038     fool_(&L__1);
17039 // FFEINTRIN_impLLE //
17040     L__1 = l_le(a1, a2, 10L, 10L);
17041     fool_(&L__1);
17042 // FFEINTRIN_impLLT //
17043     L__1 = l_lt(a1, a2, 10L, 10L);
17044     fool_(&L__1);
17045 // FFEINTRIN_impMAX0 //
17046     i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
17047     fooi_(&i__1);
17048 // FFEINTRIN_impMAX1 //
17049     i__1 = (integer) (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
17050     fooi_(&i__1);
17051 // FFEINTRIN_impMIN0 //
17052     i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
17053     fooi_(&i__1);
17054 // FFEINTRIN_impMIN1 //
17055     i__1 = (integer) (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
17056     fooi_(&i__1);
17057 // FFEINTRIN_impMOD //
17058     i__1 = i1 % i2;
17059     fooi_(&i__1);
17060 // FFEINTRIN_impNINT //
17061     i__1 = i_nint(&r1);
17062     fooi_(&i__1);
17063 // FFEINTRIN_impSIGN //
17064     r__1 = r_sign(&r1, &r2);
17065     foor_(&r__1);
17066 // FFEINTRIN_impSIN //
17067     r__1 = sin(r1);
17068     foor_(&r__1);
17069 // FFEINTRIN_impSINH //
17070     r__1 = sinh(r1);
17071     foor_(&r__1);
17072 // FFEINTRIN_impSQRT //
17073     r__1 = sqrt(r1);
17074     foor_(&r__1);
17075 // FFEINTRIN_impTAN //
17076     r__1 = tan(r1);
17077     foor_(&r__1);
17078 // FFEINTRIN_impTANH //
17079     r__1 = tanh(r1);
17080     foor_(&r__1);
17081 // FFEINTRIN_imp_CMPLX_C //
17082     r__1 = c1.r;
17083     r__2 = c2.r;
17084     q__1.r = r__1, q__1.i = r__2;
17085     fooc_(&q__1);
17086 // FFEINTRIN_imp_CMPLX_D //
17087     z__1.r = d1, z__1.i = d2;
17088     fooz_(&z__1);
17089 // FFEINTRIN_imp_CMPLX_I //
17090     r__1 = (real) i1;
17091     r__2 = (real) i2;
17092     q__1.r = r__1, q__1.i = r__2;
17093     fooc_(&q__1);
17094 // FFEINTRIN_imp_CMPLX_R //
17095     q__1.r = r1, q__1.i = r2;
17096     fooc_(&q__1);
17097 // FFEINTRIN_imp_DBLE_C //
17098     d__1 = (doublereal) c1.r;
17099     food_(&d__1);
17100 // FFEINTRIN_imp_DBLE_D //
17101     d__1 = d1;
17102     food_(&d__1);
17103 // FFEINTRIN_imp_DBLE_I //
17104     d__1 = (doublereal) i1;
17105     food_(&d__1);
17106 // FFEINTRIN_imp_DBLE_R //
17107     d__1 = (doublereal) r1;
17108     food_(&d__1);
17109 // FFEINTRIN_imp_INT_C //
17110     i__1 = (integer) c1.r;
17111     fooi_(&i__1);
17112 // FFEINTRIN_imp_INT_D //
17113     i__1 = (integer) d1;
17114     fooi_(&i__1);
17115 // FFEINTRIN_imp_INT_I //
17116     i__1 = i1;
17117     fooi_(&i__1);
17118 // FFEINTRIN_imp_INT_R //
17119     i__1 = (integer) r1;
17120     fooi_(&i__1);
17121 // FFEINTRIN_imp_REAL_C //
17122     r__1 = c1.r;
17123     foor_(&r__1);
17124 // FFEINTRIN_imp_REAL_D //
17125     r__1 = (real) d1;
17126     foor_(&r__1);
17127 // FFEINTRIN_imp_REAL_I //
17128     r__1 = (real) i1;
17129     foor_(&r__1);
17130 // FFEINTRIN_imp_REAL_R //
17131     r__1 = r1;
17132     foor_(&r__1);
17133
17134 // FFEINTRIN_imp_INT_D: //
17135
17136 // FFEINTRIN_specIDINT //
17137     i__1 = (integer) d1;
17138     fooi_(&i__1);
17139
17140 // FFEINTRIN_imp_INT_R: //
17141
17142 // FFEINTRIN_specIFIX //
17143     i__1 = (integer) r1;
17144     fooi_(&i__1);
17145 // FFEINTRIN_specINT //
17146     i__1 = (integer) r1;
17147     fooi_(&i__1);
17148
17149 // FFEINTRIN_imp_REAL_D: //
17150
17151 // FFEINTRIN_specSNGL //
17152     r__1 = (real) d1;
17153     foor_(&r__1);
17154
17155 // FFEINTRIN_imp_REAL_I: //
17156
17157 // FFEINTRIN_specFLOAT //
17158     r__1 = (real) i1;
17159     foor_(&r__1);
17160 // FFEINTRIN_specREAL //
17161     r__1 = (real) i1;
17162     foor_(&r__1);
17163
17164 } // MAIN__ //
17165
17166 -------- (end output file from f2c)
17167
17168 */