gcc/f/com.c

   1 /* com.c -- Implementation File (module.c template V1.0)
   2    Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001
   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 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
  93
  94 #define FFECOM_GCC_INCLUDE 1    /* Enable -I. */
  95
  96 /* BEGIN stuff from gcc/cccp.c.  */
  97
  98 /* The following symbols should be autoconfigured:
  99         HAVE_FCNTL_H
 100         HAVE_STDLIB_H
 101         HAVE_SYS_TIME_H
 102         HAVE_UNISTD_H
 103         STDC_HEADERS
 104         TIME_WITH_SYS_TIME
 105    In the mean time, we'll get by with approximations based
 106    on existing GCC configuration symbols.  */
 107
 108 #ifdef POSIX
 109 # ifndef HAVE_STDLIB_H
 110 # define HAVE_STDLIB_H 1
 111 # endif
 112 # ifndef HAVE_UNISTD_H
 113 # define HAVE_UNISTD_H 1
 114 # endif
 115 # ifndef STDC_HEADERS
 116 # define STDC_HEADERS 1
 117 # endif
 118 #endif /* defined (POSIX) */
 119
 120 #if defined (POSIX) || (defined (USG) && !defined (VMS))
 121 # ifndef HAVE_FCNTL_H
 122 # define HAVE_FCNTL_H 1
 123 # endif
 124 #endif
 125
 126 #ifdef RLIMIT_STACK
 127 # include <sys/resource.h>
 128 #endif
 129
 130 #if HAVE_FCNTL_H
 131 # include <fcntl.h>
 132 #endif
 133
 134 /* This defines "errno" properly for VMS, and gives us EACCES. */
 135 #include <errno.h>
 136
 137 #if HAVE_STDLIB_H
 138 # include <stdlib.h>
 139 #else
 140 char *getenv ();
 141 #endif
 142
 143 #if HAVE_UNISTD_H
 144 # include <unistd.h>
 145 #endif
 146
 147 /* VMS-specific definitions */
 148 #ifdef VMS
 149 #include <descrip.h>
 150 #define O_RDONLY        0       /* Open arg for Read/Only  */
 151 #define O_WRONLY        1       /* Open arg for Write/Only */
 152 #define read(fd,buf,size)       VMS_read (fd,buf,size)
 153 #define write(fd,buf,size)      VMS_write (fd,buf,size)
 154 #define open(fname,mode,prot)   VMS_open (fname,mode,prot)
 155 #define fopen(fname,mode)       VMS_fopen (fname,mode)
 156 #define freopen(fname,mode,ofile) VMS_freopen (fname,mode,ofile)
 157 #define strncat(dst,src,cnt) VMS_strncat (dst,src,cnt)
 158 #define fstat(fd,stbuf)         VMS_fstat (fd,stbuf)
 159 static int VMS_fstat (), VMS_stat ();
 160 static char * VMS_strncat ();
 161 static int VMS_read ();
 162 static int VMS_write ();
 163 static int VMS_open ();
 164 static FILE * VMS_fopen ();
 165 static FILE * VMS_freopen ();
 166 static void hack_vms_include_specification ();
 167 typedef struct { unsigned :16, :16, :16; } vms_ino_t;
 168 #define ino_t vms_ino_t
 169 #define INCLUDE_LEN_FUDGE 10    /* leave room for VMS syntax conversion */
 170 #endif /* VMS */
 171
 172 #ifndef O_RDONLY
 173 #define O_RDONLY 0
 174 #endif
 175
 176 /* END stuff from gcc/cccp.c.  */
 177
 178 #define FFECOM_DETERMINE_TYPES 1 /* for com.h */
 179 #include "com.h"
 180 #include "bad.h"
 181 #include "bld.h"
 182 #include "equiv.h"
 183 #include "expr.h"
 184 #include "implic.h"
 185 #include "info.h"
 186 #include "malloc.h"
 187 #include "src.h"
 188 #include "st.h"
 189 #include "storag.h"
 190 #include "symbol.h"
 191 #include "target.h"
 192 #include "top.h"
 193 #include "type.h"
 194
 195 /* Externals defined here.  */
 196
 197 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 198
 199 /* ~~gcc/tree.h *should* declare this, because toplev.c and dwarfout.c
 200    reference it.  */
 201
 202 const char * const language_string = "GNU F77";
 203
 204 /* Stream for reading from the input file.  */
 205 FILE *finput;
 206
 207 /* These definitions parallel those in c-decl.c so that code from that
 208    module can be used pretty much as is.  Much of these defs aren't
 209    otherwise used, i.e. by g77 code per se, except some of them are used
 210    to build some of them that are.  The ones that are global (i.e. not
 211    "static") are those that ste.c and such might use (directly
 212    or by using com macros that reference them in their definitions).  */
 213
 214 tree string_type_node;
 215
 216 /* The rest of these are inventions for g77, though there might be
 217    similar things in the C front end.  As they are found, these
 218    inventions should be renamed to be canonical.  Note that only
 219    the ones currently required to be global are so.  */
 220
 221 static tree ffecom_tree_fun_type_void;
 222
 223 tree ffecom_integer_type_node;  /* Abbrev for _tree_type[blah][blah]. */
 224 tree ffecom_integer_zero_node;  /* Like *_*_* with g77's integer type. */
 225 tree ffecom_integer_one_node;   /* " */
 226 tree ffecom_tree_type[FFEINFO_basictype][FFEINFO_kindtype];
 227
 228 /* _fun_type things are the f2c-specific versions.  For -fno-f2c,
 229    just use build_function_type and build_pointer_type on the
 230    appropriate _tree_type array element.  */
 231
 232 static tree ffecom_tree_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
 233 static tree ffecom_tree_ptr_to_fun_type[FFEINFO_basictype][FFEINFO_kindtype];
 234 static tree ffecom_tree_subr_type;
 235 static tree ffecom_tree_ptr_to_subr_type;
 236 static tree ffecom_tree_blockdata_type;
 237
 238 static tree ffecom_tree_xargc_;
 239
 240 ffecomSymbol ffecom_symbol_null_
 241 =
 242 {
 243   NULL_TREE,
 244   NULL_TREE,
 245   NULL_TREE,
 246   NULL_TREE,
 247   false
 248 };
 249 ffeinfoKindtype ffecom_pointer_kind_ = FFEINFO_basictypeNONE;
 250 ffeinfoKindtype ffecom_label_kind_ = FFEINFO_basictypeNONE;
 251
 252 int ffecom_f2c_typecode_[FFEINFO_basictype][FFEINFO_kindtype];
 253 tree ffecom_f2c_integer_type_node;
 254 tree ffecom_f2c_ptr_to_integer_type_node;
 255 tree ffecom_f2c_address_type_node;
 256 tree ffecom_f2c_real_type_node;
 257 tree ffecom_f2c_ptr_to_real_type_node;
 258 tree ffecom_f2c_doublereal_type_node;
 259 tree ffecom_f2c_complex_type_node;
 260 tree ffecom_f2c_doublecomplex_type_node;
 261 tree ffecom_f2c_longint_type_node;
 262 tree ffecom_f2c_logical_type_node;
 263 tree ffecom_f2c_flag_type_node;
 264 tree ffecom_f2c_ftnlen_type_node;
 265 tree ffecom_f2c_ftnlen_zero_node;
 266 tree ffecom_f2c_ftnlen_one_node;
 267 tree ffecom_f2c_ftnlen_two_node;
 268 tree ffecom_f2c_ptr_to_ftnlen_type_node;
 269 tree ffecom_f2c_ftnint_type_node;
 270 tree ffecom_f2c_ptr_to_ftnint_type_node;
 271 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 272
 273 /* Simple definitions and enumerations. */
 274
 275 #ifndef FFECOM_sizeMAXSTACKITEM
 276 #define FFECOM_sizeMAXSTACKITEM 32*1024 /* Keep user-declared things
 277                                            larger than this # bytes
 278                                            off stack if possible. */
 279 #endif
 280
 281 /* For systems that have large enough stacks, they should define
 282    this to 0, and here, for ease of use later on, we just undefine
 283    it if it is 0.  */
 284
 285 #if FFECOM_sizeMAXSTACKITEM == 0
 286 #undef FFECOM_sizeMAXSTACKITEM
 287 #endif
 288
 289 typedef enum
 290   {
 291     FFECOM_rttypeVOID_,
 292     FFECOM_rttypeVOIDSTAR_,     /* C's `void *' type. */
 293     FFECOM_rttypeFTNINT_,       /* f2c's `ftnint' type. */
 294     FFECOM_rttypeINTEGER_,      /* f2c's `integer' type. */
 295     FFECOM_rttypeLONGINT_,      /* f2c's `longint' type. */
 296     FFECOM_rttypeLOGICAL_,      /* f2c's `logical' type. */
 297     FFECOM_rttypeREAL_F2C_,     /* f2c's `real' returned as `double'. */
 298     FFECOM_rttypeREAL_GNU_,     /* `real' returned as such. */
 299     FFECOM_rttypeCOMPLEX_F2C_,  /* f2c's `complex' returned via 1st arg. */
 300     FFECOM_rttypeCOMPLEX_GNU_,  /* f2c's `complex' returned directly. */
 301     FFECOM_rttypeDOUBLE_,       /* C's `double' type. */
 302     FFECOM_rttypeDOUBLEREAL_,   /* f2c's `doublereal' type. */
 303     FFECOM_rttypeDBLCMPLX_F2C_, /* f2c's `doublecomplex' returned via 1st arg. */
 304     FFECOM_rttypeDBLCMPLX_GNU_, /* f2c's `doublecomplex' returned directly. */
 305     FFECOM_rttypeCHARACTER_,    /* f2c `char *'/`ftnlen' pair. */
 306     FFECOM_rttype_
 307   } ffecomRttype_;
 308
 309 /* Internal typedefs. */
 310
 311 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 312 typedef struct _ffecom_concat_list_ ffecomConcatList_;
 313 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 314
 315 /* Private include files. */
 316
 317
 318 /* Internal structure definitions. */
 319
 320 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 321 struct _ffecom_concat_list_
 322   {
 323     ffebld *exprs;
 324     int count;
 325     int max;
 326     ffetargetCharacterSize minlen;
 327     ffetargetCharacterSize maxlen;
 328   };
 329 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 330
 331 /* Static functions (internal). */
 332
 333 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 334 static tree ffecom_arglist_expr_ (const char *argstring, ffebld args);
 335 static tree ffecom_widest_expr_type_ (ffebld list);
 336 static bool ffecom_overlap_ (tree dest_decl, tree dest_offset,
 337                              tree dest_size, tree source_tree,
 338                              ffebld source, bool scalar_arg);
 339 static bool ffecom_args_overlapping_ (tree dest_tree, ffebld dest,
 340                                       tree args, tree callee_commons,
 341                                       bool scalar_args);
 342 static tree ffecom_build_f2c_string_ (int i, const char *s);
 343 static tree ffecom_call_ (tree fn, ffeinfoKindtype kt,
 344                           bool is_f2c_complex, tree type,
 345                           tree args, tree dest_tree,
 346                           ffebld dest, bool *dest_used,
 347                           tree callee_commons, bool scalar_args, tree hook);
 348 static tree ffecom_call_binop_ (tree fn, ffeinfoKindtype kt,
 349                                 bool is_f2c_complex, tree type,
 350                                 ffebld left, ffebld right,
 351                                 tree dest_tree, ffebld dest,
 352                                 bool *dest_used, tree callee_commons,
 353                                 bool scalar_args, bool ref, tree hook);
 354 static void ffecom_char_args_x_ (tree *xitem, tree *length,
 355                                  ffebld expr, bool with_null);
 356 static tree ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy);
 357 static tree ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s);
 358 static ffecomConcatList_
 359   ffecom_concat_list_gather_ (ffecomConcatList_ catlist,
 360                               ffebld expr,
 361                               ffetargetCharacterSize max);
 362 static void ffecom_concat_list_kill_ (ffecomConcatList_ catlist);
 363 static ffecomConcatList_ ffecom_concat_list_new_ (ffebld expr,
 364                                                 ffetargetCharacterSize max);
 365 static void ffecom_debug_kludge_ (tree aggr, const char *aggr_type,
 366                                   ffesymbol member, tree member_type,
 367                                   ffetargetOffset offset);
 368 static void ffecom_do_entry_ (ffesymbol fn, int entrynum);
 369 static tree ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
 370                           bool *dest_used, bool assignp, bool widenp);
 371 static tree ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
 372                                     ffebld dest, bool *dest_used);
 373 static tree ffecom_expr_power_integer_ (ffebld expr);
 374 static void ffecom_expr_transform_ (ffebld expr);
 375 static void ffecom_f2c_make_type_ (tree *type, int tcode, const char *name);
 376 static void ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
 377                                       int code);
 378 static ffeglobal ffecom_finish_global_ (ffeglobal global);
 379 static ffesymbol ffecom_finish_symbol_transform_ (ffesymbol s);
 380 static tree ffecom_get_appended_identifier_ (char us, const char *text);
 381 static tree ffecom_get_external_identifier_ (ffesymbol s);
 382 static tree ffecom_get_identifier_ (const char *text);
 383 static tree ffecom_gen_sfuncdef_ (ffesymbol s,
 384                                   ffeinfoBasictype bt,
 385                                   ffeinfoKindtype kt);
 386 static const char *ffecom_gfrt_args_ (ffecomGfrt ix);
 387 static tree ffecom_gfrt_tree_ (ffecomGfrt ix);
 388 static tree ffecom_init_zero_ (tree decl);
 389 static tree ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
 390                                      tree *maybe_tree);
 391 static tree ffecom_intrinsic_len_ (ffebld expr);
 392 static void ffecom_let_char_ (tree dest_tree,
 393                               tree dest_length,
 394                               ffetargetCharacterSize dest_size,
 395                               ffebld source);
 396 static void ffecom_make_gfrt_ (ffecomGfrt ix);
 397 static void ffecom_member_phase1_ (ffestorag mst, ffestorag st);
 398 static void ffecom_member_phase2_ (ffestorag mst, ffestorag st);
 399 static void ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size,
 400                                       ffebld source);
 401 static void ffecom_push_dummy_decls_ (ffebld dumlist,
 402                                       bool stmtfunc);
 403 static void ffecom_start_progunit_ (void);
 404 static ffesymbol ffecom_sym_transform_ (ffesymbol s);
 405 static ffesymbol ffecom_sym_transform_assign_ (ffesymbol s);
 406 static void ffecom_transform_common_ (ffesymbol s);
 407 static void ffecom_transform_equiv_ (ffestorag st);
 408 static tree ffecom_transform_namelist_ (ffesymbol s);
 409 static void ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
 410                                        tree t);
 411 static void ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
 412                                        tree *size, tree tree);
 413 static tree ffecom_tree_divide_ (tree tree_type, tree left, tree right,
 414                                  tree dest_tree, ffebld dest,
 415                                  bool *dest_used, tree hook);
 416 static tree ffecom_type_localvar_ (ffesymbol s,
 417                                    ffeinfoBasictype bt,
 418                                    ffeinfoKindtype kt);
 419 static tree ffecom_type_namelist_ (void);
 420 static tree ffecom_type_vardesc_ (void);
 421 static tree ffecom_vardesc_ (ffebld expr);
 422 static tree ffecom_vardesc_array_ (ffesymbol s);
 423 static tree ffecom_vardesc_dims_ (ffesymbol s);
 424 static tree ffecom_convert_narrow_ (tree type, tree expr);
 425 static tree ffecom_convert_widen_ (tree type, tree expr);
 426 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 427
 428 /* These are static functions that parallel those found in the C front
 429    end and thus have the same names.  */
 430
 431 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 432 static tree bison_rule_compstmt_ (void);
 433 static void bison_rule_pushlevel_ (void);
 434 static void delete_block (tree block);
 435 static int duplicate_decls (tree newdecl, tree olddecl);
 436 static void finish_decl (tree decl, tree init, bool is_top_level);
 437 static void finish_function (int nested);
 438 static const char *lang_printable_name (tree decl, int v);
 439 static tree lookup_name_current_level (tree name);
 440 static struct binding_level *make_binding_level (void);
 441 static void pop_f_function_context (void);
 442 static void push_f_function_context (void);
 443 static void push_parm_decl (tree parm);
 444 static tree pushdecl_top_level (tree decl);
 445 static int kept_level_p (void);
 446 static tree storedecls (tree decls);
 447 static void store_parm_decls (int is_main_program);
 448 static tree start_decl (tree decl, bool is_top_level);
 449 static void start_function (tree name, tree type, int nested, int public);
 450 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 451 #if FFECOM_GCC_INCLUDE
 452 static void ffecom_file_ (const char *name);
 453 static void ffecom_initialize_char_syntax_ (void);
 454 static void ffecom_close_include_ (FILE *f);
 455 static int ffecom_decode_include_option_ (char *spec);
 456 static FILE *ffecom_open_include_ (char *name, ffewhereLine l,
 457                                    ffewhereColumn c);
 458 #endif  /* FFECOM_GCC_INCLUDE */
 459
 460 /* Static objects accessed by functions in this module. */
 461
 462 static ffesymbol ffecom_primary_entry_ = NULL;
 463 static ffesymbol ffecom_nested_entry_ = NULL;
 464 static ffeinfoKind ffecom_primary_entry_kind_;
 465 static bool ffecom_primary_entry_is_proc_;
 466 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 467 static tree ffecom_outer_function_decl_;
 468 static tree ffecom_previous_function_decl_;
 469 static tree ffecom_which_entrypoint_decl_;
 470 static tree ffecom_float_zero_ = NULL_TREE;
 471 static tree ffecom_float_half_ = NULL_TREE;
 472 static tree ffecom_double_zero_ = NULL_TREE;
 473 static tree ffecom_double_half_ = NULL_TREE;
 474 static tree ffecom_func_result_;/* For functions. */
 475 static tree ffecom_func_length_;/* For CHARACTER fns. */
 476 static ffebld ffecom_list_blockdata_;
 477 static ffebld ffecom_list_common_;
 478 static ffebld ffecom_master_arglist_;
 479 static ffeinfoBasictype ffecom_master_bt_;
 480 static ffeinfoKindtype ffecom_master_kt_;
 481 static ffetargetCharacterSize ffecom_master_size_;
 482 static int ffecom_num_fns_ = 0;
 483 static int ffecom_num_entrypoints_ = 0;
 484 static bool ffecom_is_altreturning_ = FALSE;
 485 static tree ffecom_multi_type_node_;
 486 static tree ffecom_multi_retval_;
 487 static tree
 488   ffecom_multi_fields_[FFEINFO_basictype][FFEINFO_kindtype];
 489 static bool ffecom_member_namelisted_;  /* _member_phase1_ namelisted? */
 490 static bool ffecom_doing_entry_ = FALSE;
 491 static bool ffecom_transform_only_dummies_ = FALSE;
 492 static int ffecom_typesize_pointer_;
 493 static int ffecom_typesize_integer1_;
 494
 495 /* Holds pointer-to-function expressions.  */
 496
 497 static tree ffecom_gfrt_[FFECOM_gfrt]
 498 =
 499 {
 500 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NULL_TREE,
 501 #include "com-rt.def"
 502 #undef DEFGFRT
 503 };
 504
 505 /* Holds the external names of the functions.  */
 506
 507 static const char *ffecom_gfrt_name_[FFECOM_gfrt]
 508 =
 509 {
 510 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) NAME,
 511 #include "com-rt.def"
 512 #undef DEFGFRT
 513 };
 514
 515 /* Whether the function returns.  */
 516
 517 static bool ffecom_gfrt_volatile_[FFECOM_gfrt]
 518 =
 519 {
 520 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) VOLATILE,
 521 #include "com-rt.def"
 522 #undef DEFGFRT
 523 };
 524
 525 /* Whether the function returns type complex.  */
 526
 527 static bool ffecom_gfrt_complex_[FFECOM_gfrt]
 528 =
 529 {
 530 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) COMPLEX,
 531 #include "com-rt.def"
 532 #undef DEFGFRT
 533 };
 534
 535 /* Whether the function is const
 536    (i.e., has no side effects and only depends on its arguments).  */
 537
 538 static bool ffecom_gfrt_const_[FFECOM_gfrt]
 539 =
 540 {
 541 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) CONST,
 542 #include "com-rt.def"
 543 #undef DEFGFRT
 544 };
 545
 546 /* Type code for the function return value.  */
 547
 548 static ffecomRttype_ ffecom_gfrt_type_[FFECOM_gfrt]
 549 =
 550 {
 551 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) TYPE,
 552 #include "com-rt.def"
 553 #undef DEFGFRT
 554 };
 555
 556 /* String of codes for the function's arguments.  */
 557
 558 static const char *ffecom_gfrt_argstring_[FFECOM_gfrt]
 559 =
 560 {
 561 #define DEFGFRT(CODE,NAME,TYPE,ARGS,VOLATILE,COMPLEX,CONST) ARGS,
 562 #include "com-rt.def"
 563 #undef DEFGFRT
 564 };
 565 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 566
 567 /* Internal macros. */
 568
 569 #if FFECOM_targetCURRENT == FFECOM_targetGCC
 570
 571 /* We let tm.h override the types used here, to handle trivial differences
 572    such as the choice of unsigned int or long unsigned int for size_t.
 573    When machines start needing nontrivial differences in the size type,
 574    it would be best to do something here to figure out automatically
 575    from other information what type to use.  */
 576
 577 #ifndef SIZE_TYPE
 578 #define SIZE_TYPE "long unsigned int"
 579 #endif
 580
 581 #define ffecom_concat_list_count_(catlist) ((catlist).count)
 582 #define ffecom_concat_list_expr_(catlist,i) ((catlist).exprs[(i)])
 583 #define ffecom_concat_list_maxlen_(catlist) ((catlist).maxlen)
 584 #define ffecom_concat_list_minlen_(catlist) ((catlist).minlen)
 585
 586 #define ffecom_char_args_(i,l,e) ffecom_char_args_x_((i),(l),(e),FALSE)
 587 #define ffecom_char_args_with_null_(i,l,e) ffecom_char_args_x_((i),(l),(e),TRUE)
 588
 589 /* For each binding contour we allocate a binding_level structure
 590  * which records the names defined in that contour.
 591  * Contours include:
 592  *  0) the global one
 593  *  1) one for each function definition,
 594  *     where internal declarations of the parameters appear.
 595  *
 596  * The current meaning of a name can be found by searching the levels from
 597  * the current one out to the global one.
 598  */
 599
 600 /* Note that the information in the `names' component of the global contour
 601    is duplicated in the IDENTIFIER_GLOBAL_VALUEs of all identifiers.  */
 602
 603 struct binding_level
 604   {
 605     /* A chain of _DECL nodes for all variables, constants, functions,
 606        and typedef types.  These are in the reverse of the order supplied.
 607      */
 608     tree names;
 609
 610     /* For each level (except not the global one),
 611        a chain of BLOCK nodes for all the levels
 612        that were entered and exited one level down.  */
 613     tree blocks;
 614
 615     /* The BLOCK node for this level, if one has been preallocated.
 616        If 0, the BLOCK is allocated (if needed) when the level is popped.  */
 617     tree this_block;
 618
 619     /* The binding level which this one is contained in (inherits from).  */
 620     struct binding_level *level_chain;
 621
 622     /* 0: no ffecom_prepare_* functions called at this level yet;
 623        1: ffecom_prepare* functions called, except not ffecom_prepare_end;
 624        2: ffecom_prepare_end called.  */
 625     int prep_state;
 626   };
 627
 628 #define NULL_BINDING_LEVEL (struct binding_level *) NULL
 629
 630 /* The binding level currently in effect.  */
 631
 632 static struct binding_level *current_binding_level;
 633
 634 /* A chain of binding_level structures awaiting reuse.  */
 635
 636 static struct binding_level *free_binding_level;
 637
 638 /* The outermost binding level, for names of file scope.
 639    This is created when the compiler is started and exists
 640    through the entire run.  */
 641
 642 static struct binding_level *global_binding_level;
 643
 644 /* Binding level structures are initialized by copying this one.  */
 645
 646 static struct binding_level clear_binding_level
 647 =
 648 {NULL, NULL, NULL, NULL_BINDING_LEVEL, 0};
 649
 650 /* Language-dependent contents of an identifier.  */
 651
 652 struct lang_identifier
 653   {
 654     struct tree_identifier ignore;
 655     tree global_value, local_value, label_value;
 656     bool invented;
 657   };
 658
 659 /* Macros for access to language-specific slots in an identifier.  */
 660 /* Each of these slots contains a DECL node or null.  */
 661
 662 /* This represents the value which the identifier has in the
 663    file-scope namespace.  */
 664 #define IDENTIFIER_GLOBAL_VALUE(NODE)   \
 665   (((struct lang_identifier *)(NODE))->global_value)
 666 /* This represents the value which the identifier has in the current
 667    scope.  */
 668 #define IDENTIFIER_LOCAL_VALUE(NODE)    \
 669   (((struct lang_identifier *)(NODE))->local_value)
 670 /* This represents the value which the identifier has as a label in
 671    the current label scope.  */
 672 #define IDENTIFIER_LABEL_VALUE(NODE)    \
 673   (((struct lang_identifier *)(NODE))->label_value)
 674 /* This is nonzero if the identifier was "made up" by g77 code.  */
 675 #define IDENTIFIER_INVENTED(NODE)       \
 676   (((struct lang_identifier *)(NODE))->invented)
 677
 678 /* In identifiers, C uses the following fields in a special way:
 679    TREE_PUBLIC        to record that there was a previous local extern decl.
 680    TREE_USED          to record that such a decl was used.
 681    TREE_ADDRESSABLE   to record that the address of such a decl was used.  */
 682
 683 /* A list (chain of TREE_LIST nodes) of all LABEL_DECLs in the function
 684    that have names.  Here so we can clear out their names' definitions
 685    at the end of the function.  */
 686
 687 static tree named_labels;
 688
 689 /* A list of LABEL_DECLs from outer contexts that are currently shadowed.  */
 690
 691 static tree shadowed_labels;
 692
 693 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
 694 \f
 695 /* Return the subscript expression, modified to do range-checking.
 696
 697    `array' is the array to be checked against.
 698    `element' is the subscript expression to check.
 699    `dim' is the dimension number (starting at 0).
 700    `total_dims' is the total number of dimensions (0 for CHARACTER substring).
 701 */
 702
 703 static tree
 704 ffecom_subscript_check_ (tree array, tree element, int dim, int total_dims,
 705                          const char *array_name)
 706 {
 707   tree low = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 708   tree high = TYPE_MAX_VALUE (TYPE_DOMAIN (array));
 709   tree cond;
 710   tree die;
 711   tree args;
 712
 713   if (element == error_mark_node)
 714     return element;
 715
 716   if (TREE_TYPE (low) != TREE_TYPE (element))
 717     {
 718       if (TYPE_PRECISION (TREE_TYPE (low))
 719           > TYPE_PRECISION (TREE_TYPE (element)))
 720         element = convert (TREE_TYPE (low), element);
 721       else
 722         {
 723           low = convert (TREE_TYPE (element), low);
 724           if (high)
 725             high = convert (TREE_TYPE (element), high);
 726         }
 727     }
 728
 729   element = ffecom_save_tree (element);
 730   cond = ffecom_2 (LE_EXPR, integer_type_node,
 731                    low,
 732                    element);
 733   if (high)
 734     {
 735       cond = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
 736                        cond,
 737                        ffecom_2 (LE_EXPR, integer_type_node,
 738                                  element,
 739                                  high));
 740     }
 741
 742   {
 743     int len;
 744     char *proc;
 745     char *var;
 746     tree arg3;
 747     tree arg2;
 748     tree arg1;
 749     tree arg4;
 750
 751     switch (total_dims)
 752       {
 753       case 0:
 754         var = xmalloc (strlen (array_name) + 20);
 755         sprintf (var, "%s[%s-substring]",
 756                  array_name,
 757                  dim ? "end" : "start");
 758         len = strlen (var) + 1;
 759         arg1 = build_string (len, var);
 760         free (var);
 761         break;
 762
 763       case 1:
 764         len = strlen (array_name) + 1;
 765         arg1 = build_string (len, array_name);
 766         break;
 767
 768       default:
 769         var = xmalloc (strlen (array_name) + 40);
 770         sprintf (var, "%s[subscript-%d-of-%d]",
 771                  array_name,
 772                  dim + 1, total_dims);
 773         len = strlen (var) + 1;
 774         arg1 = build_string (len, var);
 775         free (var);
 776         break;
 777       }
 778
 779     TREE_TYPE (arg1)
 780       = build_type_variant (build_array_type (char_type_node,
 781                                               build_range_type
 782                                               (integer_type_node,
 783                                                integer_one_node,
 784                                                build_int_2 (len, 0))),
 785                             1, 0);
 786     TREE_CONSTANT (arg1) = 1;
 787     TREE_STATIC (arg1) = 1;
 788     arg1 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg1)),
 789                      arg1);
 790
 791     /* s_rnge adds one to the element to print it, so bias against
 792        that -- want to print a faithful *subscript* value.  */
 793     arg2 = convert (ffecom_f2c_ftnint_type_node,
 794                     ffecom_2 (MINUS_EXPR,
 795                               TREE_TYPE (element),
 796                               element,
 797                               convert (TREE_TYPE (element),
 798                                        integer_one_node)));
 799
 800     proc = xmalloc ((len = strlen (input_filename)
 801                      + IDENTIFIER_LENGTH (DECL_NAME (current_function_decl))
 802                      + 2));
 803
 804     sprintf (&proc[0], "%s/%s",
 805              input_filename,
 806              IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
 807     arg3 = build_string (len, proc);
 808
 809     free (proc);
 810
 811     TREE_TYPE (arg3)
 812       = build_type_variant (build_array_type (char_type_node,
 813                                               build_range_type
 814                                               (integer_type_node,
 815                                                integer_one_node,
 816                                                build_int_2 (len, 0))),
 817                             1, 0);
 818     TREE_CONSTANT (arg3) = 1;
 819     TREE_STATIC (arg3) = 1;
 820     arg3 = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (arg3)),
 821                      arg3);
 822
 823     arg4 = convert (ffecom_f2c_ftnint_type_node,
 824                     build_int_2 (lineno, 0));
 825
 826     arg1 = build_tree_list (NULL_TREE, arg1);
 827     arg2 = build_tree_list (NULL_TREE, arg2);
 828     arg3 = build_tree_list (NULL_TREE, arg3);
 829     arg4 = build_tree_list (NULL_TREE, arg4);
 830     TREE_CHAIN (arg3) = arg4;
 831     TREE_CHAIN (arg2) = arg3;
 832     TREE_CHAIN (arg1) = arg2;
 833
 834     args = arg1;
 835   }
 836   die = ffecom_call_gfrt (FFECOM_gfrtRANGE,
 837                           args, NULL_TREE);
 838   TREE_SIDE_EFFECTS (die) = 1;
 839
 840   element = ffecom_3 (COND_EXPR,
 841                       TREE_TYPE (element),
 842                       cond,
 843                       element,
 844                       die);
 845
 846   return element;
 847 }
 848
 849 /* Return the computed element of an array reference.
 850
 851    `item' is NULL_TREE, or the transformed pointer to the array.
 852    `expr' is the original opARRAYREF expression, which is transformed
 853      if `item' is NULL_TREE.
 854    `want_ptr' is non-zero if a pointer to the element, instead of
 855      the element itself, is to be returned.  */
 856
 857 static tree
 858 ffecom_arrayref_ (tree item, ffebld expr, int want_ptr)
 859 {
 860   ffebld dims[FFECOM_dimensionsMAX];
 861   int i;
 862   int total_dims;
 863   int flatten = ffe_is_flatten_arrays ();
 864   int need_ptr;
 865   tree array;
 866   tree element;
 867   tree tree_type;
 868   tree tree_type_x;
 869   const char *array_name;
 870   ffetype type;
 871   ffebld list;
 872
 873   if (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER)
 874     array_name = ffesymbol_text (ffebld_symter (ffebld_left (expr)));
 875   else
 876     array_name = "[expr?]";
 877
 878   /* Build up ARRAY_REFs in reverse order (since we're column major
 879      here in Fortran land). */
 880
 881   for (i = 0, list = ffebld_right (expr);
 882        list != NULL;
 883        ++i, list = ffebld_trail (list))
 884     {
 885       dims[i] = ffebld_head (list);
 886       type = ffeinfo_type (ffebld_basictype (dims[i]),
 887                            ffebld_kindtype (dims[i]));
 888       if (! flatten
 889           && ffecom_typesize_pointer_ > ffecom_typesize_integer1_
 890           && ffetype_size (type) > ffecom_typesize_integer1_)
 891         /* E.g. ARRAY(INDEX), given INTEGER*8 INDEX, on a system with 64-bit
 892            pointers and 32-bit integers.  Do the full 64-bit pointer
 893            arithmetic, for codes using arrays for nonstandard heap-like
 894            work.  */
 895         flatten = 1;
 896     }
 897
 898   total_dims = i;
 899
 900   need_ptr = want_ptr || flatten;
 901
 902   if (! item)
 903     {
 904       if (need_ptr)
 905         item = ffecom_ptr_to_expr (ffebld_left (expr));
 906       else
 907         item = ffecom_expr (ffebld_left (expr));
 908
 909       if (item == error_mark_node)
 910         return item;
 911
 912       if (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereFLEETING
 913           && ! mark_addressable (item))
 914         return error_mark_node;
 915     }
 916
 917   if (item == error_mark_node)
 918     return item;
 919
 920   if (need_ptr)
 921     {
 922       tree min;
 923
 924       for (--i, array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
 925            i >= 0;
 926            --i, array = TYPE_MAIN_VARIANT (TREE_TYPE (array)))
 927         {
 928           min = TYPE_MIN_VALUE (TYPE_DOMAIN (array));
 929           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 930           if (flag_bounds_check)
 931             element = ffecom_subscript_check_ (array, element, i, total_dims,
 932                                                array_name);
 933           if (element == error_mark_node)
 934             return element;
 935
 936           /* Widen integral arithmetic as desired while preserving
 937              signedness.  */
 938           tree_type = TREE_TYPE (element);
 939           tree_type_x = tree_type;
 940           if (tree_type
 941               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
 942               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
 943             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
 944
 945           if (TREE_TYPE (min) != tree_type_x)
 946             min = convert (tree_type_x, min);
 947           if (TREE_TYPE (element) != tree_type_x)
 948             element = convert (tree_type_x, element);
 949
 950           item = ffecom_2 (PLUS_EXPR,
 951                            build_pointer_type (TREE_TYPE (array)),
 952                            item,
 953                            size_binop (MULT_EXPR,
 954                                        size_in_bytes (TREE_TYPE (array)),
 955                                        convert (sizetype,
 956                                                 fold (build (MINUS_EXPR,
 957                                                              tree_type_x,
 958                                                              element, min)))));
 959         }
 960       if (! want_ptr)
 961         {
 962           item = ffecom_1 (INDIRECT_REF,
 963                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
 964                            item);
 965         }
 966     }
 967   else
 968     {
 969       for (--i;
 970            i >= 0;
 971            --i)
 972         {
 973           array = TYPE_MAIN_VARIANT (TREE_TYPE (item));
 974
 975           element = ffecom_expr_ (dims[i], NULL, NULL, NULL, FALSE, TRUE);
 976           if (flag_bounds_check)
 977             element = ffecom_subscript_check_ (array, element, i, total_dims,
 978                                                array_name);
 979           if (element == error_mark_node)
 980             return element;
 981
 982           /* Widen integral arithmetic as desired while preserving
 983              signedness.  */
 984           tree_type = TREE_TYPE (element);
 985           tree_type_x = tree_type;
 986           if (tree_type
 987               && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
 988               && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
 989             tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
 990
 991           element = convert (tree_type_x, element);
 992
 993           item = ffecom_2 (ARRAY_REF,
 994                            TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item))),
 995                            item,
 996                            element);
 997         }
 998     }
 999
1000   return item;
1001 }
1002
1003 /* This is like gcc's stabilize_reference -- in fact, most of the code
1004    comes from that -- but it handles the situation where the reference
1005    is going to have its subparts picked at, and it shouldn't change
1006    (or trigger extra invocations of functions in the subtrees) due to
1007    this.  save_expr is a bit overzealous, because we don't need the
1008    entire thing calculated and saved like a temp.  So, for DECLs, no
1009    change is needed, because these are stable aggregates, and ARRAY_REF
1010    and such might well be stable too, but for things like calculations,
1011    we do need to calculate a snapshot of a value before picking at it.  */
1012
1013 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1014 static tree
1015 ffecom_stabilize_aggregate_ (tree ref)
1016 {
1017   tree result;
1018   enum tree_code code = TREE_CODE (ref);
1019
1020   switch (code)
1021     {
1022     case VAR_DECL:
1023     case PARM_DECL:
1024     case RESULT_DECL:
1025       /* No action is needed in this case.  */
1026       return ref;
1027
1028     case NOP_EXPR:
1029     case CONVERT_EXPR:
1030     case FLOAT_EXPR:
1031     case FIX_TRUNC_EXPR:
1032     case FIX_FLOOR_EXPR:
1033     case FIX_ROUND_EXPR:
1034     case FIX_CEIL_EXPR:
1035       result = build_nt (code, stabilize_reference (TREE_OPERAND (ref, 0)));
1036       break;
1037
1038     case INDIRECT_REF:
1039       result = build_nt (INDIRECT_REF,
1040                          stabilize_reference_1 (TREE_OPERAND (ref, 0)));
1041       break;
1042
1043     case COMPONENT_REF:
1044       result = build_nt (COMPONENT_REF,
1045                          stabilize_reference (TREE_OPERAND (ref, 0)),
1046                          TREE_OPERAND (ref, 1));
1047       break;
1048
1049     case BIT_FIELD_REF:
1050       result = build_nt (BIT_FIELD_REF,
1051                          stabilize_reference (TREE_OPERAND (ref, 0)),
1052                          stabilize_reference_1 (TREE_OPERAND (ref, 1)),
1053                          stabilize_reference_1 (TREE_OPERAND (ref, 2)));
1054       break;
1055
1056     case ARRAY_REF:
1057       result = build_nt (ARRAY_REF,
1058                          stabilize_reference (TREE_OPERAND (ref, 0)),
1059                          stabilize_reference_1 (TREE_OPERAND (ref, 1)));
1060       break;
1061
1062     case COMPOUND_EXPR:
1063       result = build_nt (COMPOUND_EXPR,
1064                          stabilize_reference_1 (TREE_OPERAND (ref, 0)),
1065                          stabilize_reference (TREE_OPERAND (ref, 1)));
1066       break;
1067
1068     case RTL_EXPR:
1069       abort ();
1070
1071
1072     default:
1073       return save_expr (ref);
1074
1075     case ERROR_MARK:
1076       return error_mark_node;
1077     }
1078
1079   TREE_TYPE (result) = TREE_TYPE (ref);
1080   TREE_READONLY (result) = TREE_READONLY (ref);
1081   TREE_SIDE_EFFECTS (result) = TREE_SIDE_EFFECTS (ref);
1082   TREE_THIS_VOLATILE (result) = TREE_THIS_VOLATILE (ref);
1083
1084   return result;
1085 }
1086 #endif
1087
1088 /* A rip-off of gcc's convert.c convert_to_complex function,
1089    reworked to handle complex implemented as C structures
1090    (RECORD_TYPE with two fields, real and imaginary `r' and `i').  */
1091
1092 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1093 static tree
1094 ffecom_convert_to_complex_ (tree type, tree expr)
1095 {
1096   register enum tree_code form = TREE_CODE (TREE_TYPE (expr));
1097   tree subtype;
1098
1099   assert (TREE_CODE (type) == RECORD_TYPE);
1100
1101   subtype = TREE_TYPE (TYPE_FIELDS (type));
1102
1103   if (form == REAL_TYPE || form == INTEGER_TYPE || form == ENUMERAL_TYPE)
1104     {
1105       expr = convert (subtype, expr);
1106       return ffecom_2 (COMPLEX_EXPR, type, expr,
1107                        convert (subtype, integer_zero_node));
1108     }
1109
1110   if (form == RECORD_TYPE)
1111     {
1112       tree elt_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr)));
1113       if (TYPE_MAIN_VARIANT (elt_type) == TYPE_MAIN_VARIANT (subtype))
1114         return expr;
1115       else
1116         {
1117           expr = save_expr (expr);
1118           return ffecom_2 (COMPLEX_EXPR,
1119                            type,
1120                            convert (subtype,
1121                                     ffecom_1 (REALPART_EXPR,
1122                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1123                                               expr)),
1124                            convert (subtype,
1125                                     ffecom_1 (IMAGPART_EXPR,
1126                                               TREE_TYPE (TYPE_FIELDS (TREE_TYPE (expr))),
1127                                               expr)));
1128         }
1129     }
1130
1131   if (form == POINTER_TYPE || form == REFERENCE_TYPE)
1132     error ("pointer value used where a complex was expected");
1133   else
1134     error ("aggregate value used where a complex was expected");
1135
1136   return ffecom_2 (COMPLEX_EXPR, type,
1137                    convert (subtype, integer_zero_node),
1138                    convert (subtype, integer_zero_node));
1139 }
1140 #endif
1141
1142 /* Like gcc's convert(), but crashes if widening might happen.  */
1143
1144 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1145 static tree
1146 ffecom_convert_narrow_ (type, expr)
1147      tree type, expr;
1148 {
1149   register tree e = expr;
1150   register enum tree_code code = TREE_CODE (type);
1151
1152   if (type == TREE_TYPE (e)
1153       || TREE_CODE (e) == ERROR_MARK)
1154     return e;
1155   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1156     return fold (build1 (NOP_EXPR, type, e));
1157   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1158       || code == ERROR_MARK)
1159     return error_mark_node;
1160   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1161     {
1162       assert ("void value not ignored as it ought to be" == NULL);
1163       return error_mark_node;
1164     }
1165   assert (code != VOID_TYPE);
1166   if ((code != RECORD_TYPE)
1167       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1168     assert ("converting COMPLEX to REAL" == NULL);
1169   assert (code != ENUMERAL_TYPE);
1170   if (code == INTEGER_TYPE)
1171     {
1172       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1173                && TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)))
1174               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1175                   && (TYPE_PRECISION (type)
1176                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1177       return fold (convert_to_integer (type, e));
1178     }
1179   if (code == POINTER_TYPE)
1180     {
1181       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1182       return fold (convert_to_pointer (type, e));
1183     }
1184   if (code == REAL_TYPE)
1185     {
1186       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1187       assert (TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e)));
1188       return fold (convert_to_real (type, e));
1189     }
1190   if (code == COMPLEX_TYPE)
1191     {
1192       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1193       assert (TYPE_PRECISION (TREE_TYPE (type)) <= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1194       return fold (convert_to_complex (type, e));
1195     }
1196   if (code == RECORD_TYPE)
1197     {
1198       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1199       /* Check that at least the first field name agrees.  */
1200       assert (DECL_NAME (TYPE_FIELDS (type))
1201               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1202       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1203               <= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1204       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1205           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1206         return e;
1207       return fold (ffecom_convert_to_complex_ (type, e));
1208     }
1209
1210   assert ("conversion to non-scalar type requested" == NULL);
1211   return error_mark_node;
1212 }
1213 #endif
1214
1215 /* Like gcc's convert(), but crashes if narrowing might happen.  */
1216
1217 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1218 static tree
1219 ffecom_convert_widen_ (type, expr)
1220      tree type, expr;
1221 {
1222   register tree e = expr;
1223   register enum tree_code code = TREE_CODE (type);
1224
1225   if (type == TREE_TYPE (e)
1226       || TREE_CODE (e) == ERROR_MARK)
1227     return e;
1228   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
1229     return fold (build1 (NOP_EXPR, type, e));
1230   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
1231       || code == ERROR_MARK)
1232     return error_mark_node;
1233   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
1234     {
1235       assert ("void value not ignored as it ought to be" == NULL);
1236       return error_mark_node;
1237     }
1238   assert (code != VOID_TYPE);
1239   if ((code != RECORD_TYPE)
1240       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
1241     assert ("narrowing COMPLEX to REAL" == NULL);
1242   assert (code != ENUMERAL_TYPE);
1243   if (code == INTEGER_TYPE)
1244     {
1245       assert ((TREE_CODE (TREE_TYPE (e)) == INTEGER_TYPE
1246                && TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)))
1247               || (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE
1248                   && (TYPE_PRECISION (type)
1249                       == TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (e))))));
1250       return fold (convert_to_integer (type, e));
1251     }
1252   if (code == POINTER_TYPE)
1253     {
1254       assert (TREE_CODE (TREE_TYPE (e)) == POINTER_TYPE);
1255       return fold (convert_to_pointer (type, e));
1256     }
1257   if (code == REAL_TYPE)
1258     {
1259       assert (TREE_CODE (TREE_TYPE (e)) == REAL_TYPE);
1260       assert (TYPE_PRECISION (type) >= TYPE_PRECISION (TREE_TYPE (e)));
1261       return fold (convert_to_real (type, e));
1262     }
1263   if (code == COMPLEX_TYPE)
1264     {
1265       assert (TREE_CODE (TREE_TYPE (e)) == COMPLEX_TYPE);
1266       assert (TYPE_PRECISION (TREE_TYPE (type)) >= TYPE_PRECISION (TREE_TYPE (TREE_TYPE (e))));
1267       return fold (convert_to_complex (type, e));
1268     }
1269   if (code == RECORD_TYPE)
1270     {
1271       assert (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE);
1272       /* Check that at least the first field name agrees.  */
1273       assert (DECL_NAME (TYPE_FIELDS (type))
1274               == DECL_NAME (TYPE_FIELDS (TREE_TYPE (e))));
1275       assert (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1276               >= TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))));
1277       if (TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (type)))
1278           == TYPE_PRECISION (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e)))))
1279         return e;
1280       return fold (ffecom_convert_to_complex_ (type, e));
1281     }
1282
1283   assert ("conversion to non-scalar type requested" == NULL);
1284   return error_mark_node;
1285 }
1286 #endif
1287
1288 /* Handles making a COMPLEX type, either the standard
1289    (but buggy?) gbe way, or the safer (but less elegant?)
1290    f2c way.  */
1291
1292 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1293 static tree
1294 ffecom_make_complex_type_ (tree subtype)
1295 {
1296   tree type;
1297   tree realfield;
1298   tree imagfield;
1299
1300   if (ffe_is_emulate_complex ())
1301     {
1302       type = make_node (RECORD_TYPE);
1303       realfield = ffecom_decl_field (type, NULL_TREE, "r", subtype);
1304       imagfield = ffecom_decl_field (type, realfield, "i", subtype);
1305       TYPE_FIELDS (type) = realfield;
1306       layout_type (type);
1307     }
1308   else
1309     {
1310       type = make_node (COMPLEX_TYPE);
1311       TREE_TYPE (type) = subtype;
1312       layout_type (type);
1313     }
1314
1315   return type;
1316 }
1317 #endif
1318
1319 /* Chooses either the gbe or the f2c way to build a
1320    complex constant.  */
1321
1322 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1323 static tree
1324 ffecom_build_complex_constant_ (tree type, tree realpart, tree imagpart)
1325 {
1326   tree bothparts;
1327
1328   if (ffe_is_emulate_complex ())
1329     {
1330       bothparts = build_tree_list (TYPE_FIELDS (type), realpart);
1331       TREE_CHAIN (bothparts) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), imagpart);
1332       bothparts = build (CONSTRUCTOR, type, NULL_TREE, bothparts);
1333     }
1334   else
1335     {
1336       bothparts = build_complex (type, realpart, imagpart);
1337     }
1338
1339   return bothparts;
1340 }
1341 #endif
1342
1343 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1344 static tree
1345 ffecom_arglist_expr_ (const char *c, ffebld expr)
1346 {
1347   tree list;
1348   tree *plist = &list;
1349   tree trail = NULL_TREE;       /* Append char length args here. */
1350   tree *ptrail = &trail;
1351   tree length;
1352   ffebld exprh;
1353   tree item;
1354   bool ptr = FALSE;
1355   tree wanted = NULL_TREE;
1356   static char zed[] = "0";
1357
1358   if (c == NULL)
1359     c = &zed[0];
1360
1361   while (expr != NULL)
1362     {
1363       if (*c != '\0')
1364         {
1365           ptr = FALSE;
1366           if (*c == '&')
1367             {
1368               ptr = TRUE;
1369               ++c;
1370             }
1371           switch (*(c++))
1372             {
1373             case '\0':
1374               ptr = TRUE;
1375               wanted = NULL_TREE;
1376               break;
1377
1378             case 'a':
1379               assert (ptr);
1380               wanted = NULL_TREE;
1381               break;
1382
1383             case 'c':
1384               wanted = ffecom_f2c_complex_type_node;
1385               break;
1386
1387             case 'd':
1388               wanted = ffecom_f2c_doublereal_type_node;
1389               break;
1390
1391             case 'e':
1392               wanted = ffecom_f2c_doublecomplex_type_node;
1393               break;
1394
1395             case 'f':
1396               wanted = ffecom_f2c_real_type_node;
1397               break;
1398
1399             case 'i':
1400               wanted = ffecom_f2c_integer_type_node;
1401               break;
1402
1403             case 'j':
1404               wanted = ffecom_f2c_longint_type_node;
1405               break;
1406
1407             default:
1408               assert ("bad argstring code" == NULL);
1409               wanted = NULL_TREE;
1410               break;
1411             }
1412         }
1413
1414       exprh = ffebld_head (expr);
1415       if (exprh == NULL)
1416         wanted = NULL_TREE;
1417
1418       if ((wanted == NULL_TREE)
1419           || (ptr
1420               && (TYPE_MODE
1421                   (ffecom_tree_type[ffeinfo_basictype (ffebld_info (exprh))]
1422                    [ffeinfo_kindtype (ffebld_info (exprh))])
1423                    == TYPE_MODE (wanted))))
1424         *plist
1425           = build_tree_list (NULL_TREE,
1426                              ffecom_arg_ptr_to_expr (exprh,
1427                                                      &length));
1428       else
1429         {
1430           item = ffecom_arg_expr (exprh, &length);
1431           item = ffecom_convert_widen_ (wanted, item);
1432           if (ptr)
1433             {
1434               item = ffecom_1 (ADDR_EXPR,
1435                                build_pointer_type (TREE_TYPE (item)),
1436                                item);
1437             }
1438           *plist
1439             = build_tree_list (NULL_TREE,
1440                                item);
1441         }
1442
1443       plist = &TREE_CHAIN (*plist);
1444       expr = ffebld_trail (expr);
1445       if (length != NULL_TREE)
1446         {
1447           *ptrail = build_tree_list (NULL_TREE, length);
1448           ptrail = &TREE_CHAIN (*ptrail);
1449         }
1450     }
1451
1452   /* We've run out of args in the call; if the implementation expects
1453      more, supply null pointers for them, which the implementation can
1454      check to see if an arg was omitted. */
1455
1456   while (*c != '\0' && *c != '0')
1457     {
1458       if (*c == '&')
1459         ++c;
1460       else
1461         assert ("missing arg to run-time routine!" == NULL);
1462
1463       switch (*(c++))
1464         {
1465         case '\0':
1466         case 'a':
1467         case 'c':
1468         case 'd':
1469         case 'e':
1470         case 'f':
1471         case 'i':
1472         case 'j':
1473           break;
1474
1475         default:
1476           assert ("bad arg string code" == NULL);
1477           break;
1478         }
1479       *plist
1480         = build_tree_list (NULL_TREE,
1481                            null_pointer_node);
1482       plist = &TREE_CHAIN (*plist);
1483     }
1484
1485   *plist = trail;
1486
1487   return list;
1488 }
1489 #endif
1490
1491 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1492 static tree
1493 ffecom_widest_expr_type_ (ffebld list)
1494 {
1495   ffebld item;
1496   ffebld widest = NULL;
1497   ffetype type;
1498   ffetype widest_type = NULL;
1499   tree t;
1500
1501   for (; list != NULL; list = ffebld_trail (list))
1502     {
1503       item = ffebld_head (list);
1504       if (item == NULL)
1505         continue;
1506       if ((widest != NULL)
1507           && (ffeinfo_basictype (ffebld_info (item))
1508               != ffeinfo_basictype (ffebld_info (widest))))
1509         continue;
1510       type = ffeinfo_type (ffeinfo_basictype (ffebld_info (item)),
1511                            ffeinfo_kindtype (ffebld_info (item)));
1512       if ((widest == FFEINFO_kindtypeNONE)
1513           || (ffetype_size (type)
1514               > ffetype_size (widest_type)))
1515         {
1516           widest = item;
1517           widest_type = type;
1518         }
1519     }
1520
1521   assert (widest != NULL);
1522   t = ffecom_tree_type[ffeinfo_basictype (ffebld_info (widest))]
1523     [ffeinfo_kindtype (ffebld_info (widest))];
1524   assert (t != NULL_TREE);
1525   return t;
1526 }
1527 #endif
1528
1529 /* Check whether a partial overlap between two expressions is possible.
1530
1531    Can *starting* to write a portion of expr1 change the value
1532    computed (perhaps already, *partially*) by expr2?
1533
1534    Currently, this is a concern only for a COMPLEX expr1.  But if it
1535    isn't in COMMON or local EQUIVALENCE, since we don't support
1536    aliasing of arguments, it isn't a concern.  */
1537
1538 static bool
1539 ffecom_possible_partial_overlap_ (ffebld expr1, ffebld expr2 ATTRIBUTE_UNUSED)
1540 {
1541   ffesymbol sym;
1542   ffestorag st;
1543
1544   switch (ffebld_op (expr1))
1545     {
1546     case FFEBLD_opSYMTER:
1547       sym = ffebld_symter (expr1);
1548       break;
1549
1550     case FFEBLD_opARRAYREF:
1551       if (ffebld_op (ffebld_left (expr1)) != FFEBLD_opSYMTER)
1552         return FALSE;
1553       sym = ffebld_symter (ffebld_left (expr1));
1554       break;
1555
1556     default:
1557       return FALSE;
1558     }
1559
1560   if (ffesymbol_where (sym) != FFEINFO_whereCOMMON
1561       && (ffesymbol_where (sym) != FFEINFO_whereLOCAL
1562           || ! (st = ffesymbol_storage (sym))
1563           || ! ffestorag_parent (st)))
1564     return FALSE;
1565
1566   /* It's in COMMON or local EQUIVALENCE.  */
1567
1568   return TRUE;
1569 }
1570
1571 /* Check whether dest and source might overlap.  ffebld versions of these
1572    might or might not be passed, will be NULL if not.
1573
1574    The test is really whether source_tree is modifiable and, if modified,
1575    might overlap destination such that the value(s) in the destination might
1576    change before it is finally modified.  dest_* are the canonized
1577    destination itself.  */
1578
1579 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1580 static bool
1581 ffecom_overlap_ (tree dest_decl, tree dest_offset, tree dest_size,
1582                  tree source_tree, ffebld source UNUSED,
1583                  bool scalar_arg)
1584 {
1585   tree source_decl;
1586   tree source_offset;
1587   tree source_size;
1588   tree t;
1589
1590   if (source_tree == NULL_TREE)
1591     return FALSE;
1592
1593   switch (TREE_CODE (source_tree))
1594     {
1595     case ERROR_MARK:
1596     case IDENTIFIER_NODE:
1597     case INTEGER_CST:
1598     case REAL_CST:
1599     case COMPLEX_CST:
1600     case STRING_CST:
1601     case CONST_DECL:
1602     case VAR_DECL:
1603     case RESULT_DECL:
1604     case FIELD_DECL:
1605     case MINUS_EXPR:
1606     case MULT_EXPR:
1607     case TRUNC_DIV_EXPR:
1608     case CEIL_DIV_EXPR:
1609     case FLOOR_DIV_EXPR:
1610     case ROUND_DIV_EXPR:
1611     case TRUNC_MOD_EXPR:
1612     case CEIL_MOD_EXPR:
1613     case FLOOR_MOD_EXPR:
1614     case ROUND_MOD_EXPR:
1615     case RDIV_EXPR:
1616     case EXACT_DIV_EXPR:
1617     case FIX_TRUNC_EXPR:
1618     case FIX_CEIL_EXPR:
1619     case FIX_FLOOR_EXPR:
1620     case FIX_ROUND_EXPR:
1621     case FLOAT_EXPR:
1622     case EXPON_EXPR:
1623     case NEGATE_EXPR:
1624     case MIN_EXPR:
1625     case MAX_EXPR:
1626     case ABS_EXPR:
1627     case FFS_EXPR:
1628     case LSHIFT_EXPR:
1629     case RSHIFT_EXPR:
1630     case LROTATE_EXPR:
1631     case RROTATE_EXPR:
1632     case BIT_IOR_EXPR:
1633     case BIT_XOR_EXPR:
1634     case BIT_AND_EXPR:
1635     case BIT_ANDTC_EXPR:
1636     case BIT_NOT_EXPR:
1637     case TRUTH_ANDIF_EXPR:
1638     case TRUTH_ORIF_EXPR:
1639     case TRUTH_AND_EXPR:
1640     case TRUTH_OR_EXPR:
1641     case TRUTH_XOR_EXPR:
1642     case TRUTH_NOT_EXPR:
1643     case LT_EXPR:
1644     case LE_EXPR:
1645     case GT_EXPR:
1646     case GE_EXPR:
1647     case EQ_EXPR:
1648     case NE_EXPR:
1649     case COMPLEX_EXPR:
1650     case CONJ_EXPR:
1651     case REALPART_EXPR:
1652     case IMAGPART_EXPR:
1653     case LABEL_EXPR:
1654     case COMPONENT_REF:
1655       return FALSE;
1656
1657     case COMPOUND_EXPR:
1658       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1659                               TREE_OPERAND (source_tree, 1), NULL,
1660                               scalar_arg);
1661
1662     case MODIFY_EXPR:
1663       return ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1664                               TREE_OPERAND (source_tree, 0), NULL,
1665                               scalar_arg);
1666
1667     case CONVERT_EXPR:
1668     case NOP_EXPR:
1669     case NON_LVALUE_EXPR:
1670     case PLUS_EXPR:
1671       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1672         return TRUE;
1673
1674       ffecom_tree_canonize_ptr_ (&source_decl, &source_offset,
1675                                  source_tree);
1676       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1677       break;
1678
1679     case COND_EXPR:
1680       return
1681         ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1682                          TREE_OPERAND (source_tree, 1), NULL,
1683                          scalar_arg)
1684           || ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1685                               TREE_OPERAND (source_tree, 2), NULL,
1686                               scalar_arg);
1687
1688
1689     case ADDR_EXPR:
1690       ffecom_tree_canonize_ref_ (&source_decl, &source_offset,
1691                                  &source_size,
1692                                  TREE_OPERAND (source_tree, 0));
1693       break;
1694
1695     case PARM_DECL:
1696       if (TREE_CODE (TREE_TYPE (source_tree)) != POINTER_TYPE)
1697         return TRUE;
1698
1699       source_decl = source_tree;
1700       source_offset = bitsize_zero_node;
1701       source_size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (source_tree)));
1702       break;
1703
1704     case SAVE_EXPR:
1705     case REFERENCE_EXPR:
1706     case PREDECREMENT_EXPR:
1707     case PREINCREMENT_EXPR:
1708     case POSTDECREMENT_EXPR:
1709     case POSTINCREMENT_EXPR:
1710     case INDIRECT_REF:
1711     case ARRAY_REF:
1712     case CALL_EXPR:
1713     default:
1714       return TRUE;
1715     }
1716
1717   /* Come here when source_decl, source_offset, and source_size filled
1718      in appropriately.  */
1719
1720   if (source_decl == NULL_TREE)
1721     return FALSE;               /* No decl involved, so no overlap. */
1722
1723   if (source_decl != dest_decl)
1724     return FALSE;               /* Different decl, no overlap. */
1725
1726   if (TREE_CODE (dest_size) == ERROR_MARK)
1727     return TRUE;                /* Assignment into entire assumed-size
1728                                    array?  Shouldn't happen.... */
1729
1730   t = ffecom_2 (LE_EXPR, integer_type_node,
1731                 ffecom_2 (PLUS_EXPR, TREE_TYPE (dest_offset),
1732                           dest_offset,
1733                           convert (TREE_TYPE (dest_offset),
1734                                    dest_size)),
1735                 convert (TREE_TYPE (dest_offset),
1736                          source_offset));
1737
1738   if (integer_onep (t))
1739     return FALSE;               /* Destination precedes source. */
1740
1741   if (!scalar_arg
1742       || (source_size == NULL_TREE)
1743       || (TREE_CODE (source_size) == ERROR_MARK)
1744       || integer_zerop (source_size))
1745     return TRUE;                /* No way to tell if dest follows source. */
1746
1747   t = ffecom_2 (LE_EXPR, integer_type_node,
1748                 ffecom_2 (PLUS_EXPR, TREE_TYPE (source_offset),
1749                           source_offset,
1750                           convert (TREE_TYPE (source_offset),
1751                                    source_size)),
1752                 convert (TREE_TYPE (source_offset),
1753                          dest_offset));
1754
1755   if (integer_onep (t))
1756     return FALSE;               /* Destination follows source. */
1757
1758   return TRUE;          /* Destination and source overlap. */
1759 }
1760 #endif
1761
1762 /* Check whether dest might overlap any of a list of arguments or is
1763    in a COMMON area the callee might know about (and thus modify).  */
1764
1765 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1766 static bool
1767 ffecom_args_overlapping_ (tree dest_tree, ffebld dest UNUSED,
1768                           tree args, tree callee_commons,
1769                           bool scalar_args)
1770 {
1771   tree arg;
1772   tree dest_decl;
1773   tree dest_offset;
1774   tree dest_size;
1775
1776   ffecom_tree_canonize_ref_ (&dest_decl, &dest_offset, &dest_size,
1777                              dest_tree);
1778
1779   if (dest_decl == NULL_TREE)
1780     return FALSE;               /* Seems unlikely! */
1781
1782   /* If the decl cannot be determined reliably, or if its in COMMON
1783      and the callee isn't known to not futz with COMMON via other
1784      means, overlap might happen.  */
1785
1786   if ((TREE_CODE (dest_decl) == ERROR_MARK)
1787       || ((callee_commons != NULL_TREE)
1788           && TREE_PUBLIC (dest_decl)))
1789     return TRUE;
1790
1791   for (; args != NULL_TREE; args = TREE_CHAIN (args))
1792     {
1793       if (((arg = TREE_VALUE (args)) != NULL_TREE)
1794           && ffecom_overlap_ (dest_decl, dest_offset, dest_size,
1795                               arg, NULL, scalar_args))
1796         return TRUE;
1797     }
1798
1799   return FALSE;
1800 }
1801 #endif
1802
1803 /* Build a string for a variable name as used by NAMELIST.  This means that
1804    if we're using the f2c library, we build an uppercase string, since
1805    f2c does this.  */
1806
1807 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1808 static tree
1809 ffecom_build_f2c_string_ (int i, const char *s)
1810 {
1811   if (!ffe_is_f2c_library ())
1812     return build_string (i, s);
1813
1814   {
1815     char *tmp;
1816     const char *p;
1817     char *q;
1818     char space[34];
1819     tree t;
1820
1821     if (((size_t) i) > ARRAY_SIZE (space))
1822       tmp = malloc_new_ks (malloc_pool_image (), "f2c_string", i);
1823     else
1824       tmp = &space[0];
1825
1826     for (p = s, q = tmp; *p != '\0'; ++p, ++q)
1827       *q = TOUPPER (*p);
1828     *q = '\0';
1829
1830     t = build_string (i, tmp);
1831
1832     if (((size_t) i) > ARRAY_SIZE (space))
1833       malloc_kill_ks (malloc_pool_image (), tmp, i);
1834
1835     return t;
1836   }
1837 }
1838
1839 #endif
1840 /* Returns CALL_EXPR or equivalent with given type (pass NULL_TREE for
1841    type to just get whatever the function returns), handling the
1842    f2c value-returning convention, if required, by prepending
1843    to the arglist a pointer to a temporary to receive the return value.  */
1844
1845 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1846 static tree
1847 ffecom_call_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1848               tree type, tree args, tree dest_tree,
1849               ffebld dest, bool *dest_used, tree callee_commons,
1850               bool scalar_args, tree hook)
1851 {
1852   tree item;
1853   tree tempvar;
1854
1855   if (dest_used != NULL)
1856     *dest_used = FALSE;
1857
1858   if (is_f2c_complex)
1859     {
1860       if ((dest_used == NULL)
1861           || (dest == NULL)
1862           || (ffeinfo_basictype (ffebld_info (dest))
1863               != FFEINFO_basictypeCOMPLEX)
1864           || (ffeinfo_kindtype (ffebld_info (dest)) != kt)
1865           || ((type != NULL_TREE) && (TREE_TYPE (dest_tree) != type))
1866           || ffecom_args_overlapping_ (dest_tree, dest, args,
1867                                        callee_commons,
1868                                        scalar_args))
1869         {
1870 #ifdef HOHO
1871           tempvar = ffecom_make_tempvar (ffecom_tree_type
1872                                          [FFEINFO_basictypeCOMPLEX][kt],
1873                                          FFETARGET_charactersizeNONE,
1874                                          -1);
1875 #else
1876           tempvar = hook;
1877           assert (tempvar);
1878 #endif
1879         }
1880       else
1881         {
1882           *dest_used = TRUE;
1883           tempvar = dest_tree;
1884           type = NULL_TREE;
1885         }
1886
1887       item
1888         = build_tree_list (NULL_TREE,
1889                            ffecom_1 (ADDR_EXPR,
1890                                      build_pointer_type (TREE_TYPE (tempvar)),
1891                                      tempvar));
1892       TREE_CHAIN (item) = args;
1893
1894       item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1895                         item, NULL_TREE);
1896
1897       if (tempvar != dest_tree)
1898         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item, tempvar);
1899     }
1900   else
1901     item = ffecom_3s (CALL_EXPR, TREE_TYPE (TREE_TYPE (TREE_TYPE (fn))), fn,
1902                       args, NULL_TREE);
1903
1904   if ((type != NULL_TREE) && (TREE_TYPE (item) != type))
1905     item = ffecom_convert_narrow_ (type, item);
1906
1907   return item;
1908 }
1909 #endif
1910
1911 /* Given two arguments, transform them and make a call to the given
1912    function via ffecom_call_.  */
1913
1914 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1915 static tree
1916 ffecom_call_binop_ (tree fn, ffeinfoKindtype kt, bool is_f2c_complex,
1917                     tree type, ffebld left, ffebld right,
1918                     tree dest_tree, ffebld dest, bool *dest_used,
1919                     tree callee_commons, bool scalar_args, bool ref, tree hook)
1920 {
1921   tree left_tree;
1922   tree right_tree;
1923   tree left_length;
1924   tree right_length;
1925
1926   if (ref)
1927     {
1928       /* Pass arguments by reference.  */
1929       left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
1930       right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
1931     }
1932   else
1933     {
1934       /* Pass arguments by value.  */
1935       left_tree = ffecom_arg_expr (left, &left_length);
1936       right_tree = ffecom_arg_expr (right, &right_length);
1937     }
1938
1939
1940   left_tree = build_tree_list (NULL_TREE, left_tree);
1941   right_tree = build_tree_list (NULL_TREE, right_tree);
1942   TREE_CHAIN (left_tree) = right_tree;
1943
1944   if (left_length != NULL_TREE)
1945     {
1946       left_length = build_tree_list (NULL_TREE, left_length);
1947       TREE_CHAIN (right_tree) = left_length;
1948     }
1949
1950   if (right_length != NULL_TREE)
1951     {
1952       right_length = build_tree_list (NULL_TREE, right_length);
1953       if (left_length != NULL_TREE)
1954         TREE_CHAIN (left_length) = right_length;
1955       else
1956         TREE_CHAIN (right_tree) = right_length;
1957     }
1958
1959   return ffecom_call_ (fn, kt, is_f2c_complex, type, left_tree,
1960                        dest_tree, dest, dest_used, callee_commons,
1961                        scalar_args, hook);
1962 }
1963 #endif
1964
1965 /* Return ptr/length args for char subexpression
1966
1967    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
1968    subexpressions by constructing the appropriate trees for the ptr-to-
1969    character-text and length-of-character-text arguments in a calling
1970    sequence.
1971
1972    Note that if with_null is TRUE, and the expression is an opCONTER,
1973    a null byte is appended to the string.  */
1974
1975 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1976 static void
1977 ffecom_char_args_x_ (tree *xitem, tree *length, ffebld expr, bool with_null)
1978 {
1979   tree item;
1980   tree high;
1981   ffetargetCharacter1 val;
1982   ffetargetCharacterSize newlen;
1983
1984   switch (ffebld_op (expr))
1985     {
1986     case FFEBLD_opCONTER:
1987       val = ffebld_constant_character1 (ffebld_conter (expr));
1988       newlen = ffetarget_length_character1 (val);
1989       if (with_null)
1990         {
1991           /* Begin FFETARGET-NULL-KLUDGE.  */
1992           if (newlen != 0)
1993             ++newlen;
1994         }
1995       *length = build_int_2 (newlen, 0);
1996       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
1997       high = build_int_2 (newlen, 0);
1998       TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
1999       item = build_string (newlen,
2000                            ffetarget_text_character1 (val));
2001       /* End FFETARGET-NULL-KLUDGE.  */
2002       TREE_TYPE (item)
2003         = build_type_variant
2004           (build_array_type
2005            (char_type_node,
2006             build_range_type
2007             (ffecom_f2c_ftnlen_type_node,
2008              ffecom_f2c_ftnlen_one_node,
2009              high)),
2010            1, 0);
2011       TREE_CONSTANT (item) = 1;
2012       TREE_STATIC (item) = 1;
2013       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
2014                        item);
2015       break;
2016
2017     case FFEBLD_opSYMTER:
2018       {
2019         ffesymbol s = ffebld_symter (expr);
2020
2021         item = ffesymbol_hook (s).decl_tree;
2022         if (item == NULL_TREE)
2023           {
2024             s = ffecom_sym_transform_ (s);
2025             item = ffesymbol_hook (s).decl_tree;
2026           }
2027         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
2028           {
2029             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
2030               *length = ffesymbol_hook (s).length_tree;
2031             else
2032               {
2033                 *length = build_int_2 (ffesymbol_size (s), 0);
2034                 TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2035               }
2036           }
2037         else if (item == error_mark_node)
2038           *length = error_mark_node;
2039         else
2040           /* FFEINFO_kindFUNCTION.  */
2041           *length = NULL_TREE;
2042         if (!ffesymbol_hook (s).addr
2043             && (item != error_mark_node))
2044           item = ffecom_1 (ADDR_EXPR,
2045                            build_pointer_type (TREE_TYPE (item)),
2046                            item);
2047       }
2048       break;
2049
2050     case FFEBLD_opARRAYREF:
2051       {
2052         ffecom_char_args_ (&item, length, ffebld_left (expr));
2053
2054         if (item == error_mark_node || *length == error_mark_node)
2055           {
2056             item = *length = error_mark_node;
2057             break;
2058           }
2059
2060         item = ffecom_arrayref_ (item, expr, 1);
2061       }
2062       break;
2063
2064     case FFEBLD_opSUBSTR:
2065       {
2066         ffebld start;
2067         ffebld end;
2068         ffebld thing = ffebld_right (expr);
2069         tree start_tree;
2070         tree end_tree;
2071         const char *char_name;
2072         ffebld left_symter;
2073         tree array;
2074
2075         assert (ffebld_op (thing) == FFEBLD_opITEM);
2076         start = ffebld_head (thing);
2077         thing = ffebld_trail (thing);
2078         assert (ffebld_trail (thing) == NULL);
2079         end = ffebld_head (thing);
2080
2081         /* Determine name for pretty-printing range-check errors.  */
2082         for (left_symter = ffebld_left (expr);
2083              left_symter && ffebld_op (left_symter) == FFEBLD_opARRAYREF;
2084              left_symter = ffebld_left (left_symter))
2085           ;
2086         if (ffebld_op (left_symter) == FFEBLD_opSYMTER)
2087           char_name = ffesymbol_text (ffebld_symter (left_symter));
2088         else
2089           char_name = "[expr?]";
2090
2091         ffecom_char_args_ (&item, length, ffebld_left (expr));
2092
2093         if (item == error_mark_node || *length == error_mark_node)
2094           {
2095             item = *length = error_mark_node;
2096             break;
2097           }
2098
2099         array = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item)));
2100
2101         /* ~~~~Handle INTEGER*8 start/end, a la FFEBLD_opARRAYREF.  */
2102
2103         if (start == NULL)
2104           {
2105             if (end == NULL)
2106               ;
2107             else
2108               {
2109                 end_tree = ffecom_expr (end);
2110                 if (flag_bounds_check)
2111                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2112                                                       char_name);
2113                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2114                                     end_tree);
2115
2116                 if (end_tree == error_mark_node)
2117                   {
2118                     item = *length = error_mark_node;
2119                     break;
2120                   }
2121
2122                 *length = end_tree;
2123               }
2124           }
2125         else
2126           {
2127             start_tree = ffecom_expr (start);
2128             if (flag_bounds_check)
2129               start_tree = ffecom_subscript_check_ (array, start_tree, 0, 0,
2130                                                     char_name);
2131             start_tree = convert (ffecom_f2c_ftnlen_type_node,
2132                                   start_tree);
2133
2134             if (start_tree == error_mark_node)
2135               {
2136                 item = *length = error_mark_node;
2137                 break;
2138               }
2139
2140             start_tree = ffecom_save_tree (start_tree);
2141
2142             item = ffecom_2 (PLUS_EXPR, TREE_TYPE (item),
2143                              item,
2144                              ffecom_2 (MINUS_EXPR,
2145                                        TREE_TYPE (start_tree),
2146                                        start_tree,
2147                                        ffecom_f2c_ftnlen_one_node));
2148
2149             if (end == NULL)
2150               {
2151                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2152                                     ffecom_f2c_ftnlen_one_node,
2153                                     ffecom_2 (MINUS_EXPR,
2154                                               ffecom_f2c_ftnlen_type_node,
2155                                               *length,
2156                                               start_tree));
2157               }
2158             else
2159               {
2160                 end_tree = ffecom_expr (end);
2161                 if (flag_bounds_check)
2162                   end_tree = ffecom_subscript_check_ (array, end_tree, 1, 0,
2163                                                       char_name);
2164                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
2165                                     end_tree);
2166
2167                 if (end_tree == error_mark_node)
2168                   {
2169                     item = *length = error_mark_node;
2170                     break;
2171                   }
2172
2173                 *length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
2174                                     ffecom_f2c_ftnlen_one_node,
2175                                     ffecom_2 (MINUS_EXPR,
2176                                               ffecom_f2c_ftnlen_type_node,
2177                                               end_tree, start_tree));
2178               }
2179           }
2180       }
2181       break;
2182
2183     case FFEBLD_opFUNCREF:
2184       {
2185         ffesymbol s = ffebld_symter (ffebld_left (expr));
2186         tree tempvar;
2187         tree args;
2188         ffetargetCharacterSize size = ffeinfo_size (ffebld_info (expr));
2189         ffecomGfrt ix;
2190
2191         if (size == FFETARGET_charactersizeNONE)
2192           /* ~~Kludge alert!  This should someday be fixed. */
2193           size = 24;
2194
2195         *length = build_int_2 (size, 0);
2196         TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2197
2198         if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
2199             == FFEINFO_whereINTRINSIC)
2200           {
2201             if (size == 1)
2202               {
2203                 /* Invocation of an intrinsic returning CHARACTER*1.  */
2204                 item = ffecom_expr_intrinsic_ (expr, NULL_TREE,
2205                                                NULL, NULL);
2206                 break;
2207               }
2208             ix = ffeintrin_gfrt_direct (ffebld_symter_implementation (ffebld_left (expr)));
2209             assert (ix != FFECOM_gfrt);
2210             item = ffecom_gfrt_tree_ (ix);
2211           }
2212         else
2213           {
2214             ix = FFECOM_gfrt;
2215             item = ffesymbol_hook (s).decl_tree;
2216             if (item == NULL_TREE)
2217               {
2218                 s = ffecom_sym_transform_ (s);
2219                 item = ffesymbol_hook (s).decl_tree;
2220               }
2221             if (item == error_mark_node)
2222               {
2223                 item = *length = error_mark_node;
2224                 break;
2225               }
2226
2227             if (!ffesymbol_hook (s).addr)
2228               item = ffecom_1_fn (item);
2229           }
2230
2231 #ifdef HOHO
2232         tempvar = ffecom_push_tempvar (char_type_node, size, -1, TRUE);
2233 #else
2234         tempvar = ffebld_nonter_hook (expr);
2235         assert (tempvar);
2236 #endif
2237         tempvar = ffecom_1 (ADDR_EXPR,
2238                             build_pointer_type (TREE_TYPE (tempvar)),
2239                             tempvar);
2240
2241         args = build_tree_list (NULL_TREE, tempvar);
2242
2243         if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)       /* Sfunc args by value. */
2244           TREE_CHAIN (args) = ffecom_list_expr (ffebld_right (expr));
2245         else
2246           {
2247             TREE_CHAIN (args) = build_tree_list (NULL_TREE, *length);
2248             if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
2249               {
2250                 TREE_CHAIN (TREE_CHAIN (args))
2251                   = ffecom_arglist_expr_ (ffecom_gfrt_args_ (ix),
2252                                           ffebld_right (expr));
2253               }
2254             else
2255               {
2256                 TREE_CHAIN (TREE_CHAIN (args))
2257                   = ffecom_list_ptr_to_expr (ffebld_right (expr));
2258               }
2259           }
2260
2261         item = ffecom_3s (CALL_EXPR,
2262                           TREE_TYPE (TREE_TYPE (TREE_TYPE (item))),
2263                           item, args, NULL_TREE);
2264         item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), item,
2265                          tempvar);
2266       }
2267       break;
2268
2269     case FFEBLD_opCONVERT:
2270
2271       ffecom_char_args_ (&item, length, ffebld_left (expr));
2272
2273       if (item == error_mark_node || *length == error_mark_node)
2274         {
2275           item = *length = error_mark_node;
2276           break;
2277         }
2278
2279       if ((ffebld_size_known (ffebld_left (expr))
2280            == FFETARGET_charactersizeNONE)
2281           || (ffebld_size_known (ffebld_left (expr)) < (ffebld_size (expr))))
2282         {                       /* Possible blank-padding needed, copy into
2283                                    temporary. */
2284           tree tempvar;
2285           tree args;
2286           tree newlen;
2287
2288 #ifdef HOHO
2289           tempvar = ffecom_make_tempvar (char_type_node,
2290                                          ffebld_size (expr), -1);
2291 #else
2292           tempvar = ffebld_nonter_hook (expr);
2293           assert (tempvar);
2294 #endif
2295           tempvar = ffecom_1 (ADDR_EXPR,
2296                               build_pointer_type (TREE_TYPE (tempvar)),
2297                               tempvar);
2298
2299           newlen = build_int_2 (ffebld_size (expr), 0);
2300           TREE_TYPE (newlen) = ffecom_f2c_ftnlen_type_node;
2301
2302           args = build_tree_list (NULL_TREE, tempvar);
2303           TREE_CHAIN (args) = build_tree_list (NULL_TREE, item);
2304           TREE_CHAIN (TREE_CHAIN (args)) = build_tree_list (NULL_TREE, newlen);
2305           TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (args)))
2306             = build_tree_list (NULL_TREE, *length);
2307
2308           item = ffecom_call_gfrt (FFECOM_gfrtCOPY, args, NULL_TREE);
2309           TREE_SIDE_EFFECTS (item) = 1;
2310           item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar), fold (item),
2311                            tempvar);
2312           *length = newlen;
2313         }
2314       else
2315         {                       /* Just truncate the length. */
2316           *length = build_int_2 (ffebld_size (expr), 0);
2317           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
2318         }
2319       break;
2320
2321     default:
2322       assert ("bad op for single char arg expr" == NULL);
2323       item = NULL_TREE;
2324       break;
2325     }
2326
2327   *xitem = item;
2328 }
2329 #endif
2330
2331 /* Check the size of the type to be sure it doesn't overflow the
2332    "portable" capacities of the compiler back end.  `dummy' types
2333    can generally overflow the normal sizes as long as the computations
2334    themselves don't overflow.  A particular target of the back end
2335    must still enforce its size requirements, though, and the back
2336    end takes care of this in stor-layout.c.  */
2337
2338 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2339 static tree
2340 ffecom_check_size_overflow_ (ffesymbol s, tree type, bool dummy)
2341 {
2342   if (TREE_CODE (type) == ERROR_MARK)
2343     return type;
2344
2345   if (TYPE_SIZE (type) == NULL_TREE)
2346     return type;
2347
2348   if (TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST)
2349     return type;
2350
2351   if ((tree_int_cst_sgn (TYPE_SIZE (type)) < 0)
2352       || (!dummy && (((TREE_INT_CST_HIGH (TYPE_SIZE (type)) != 0))
2353                      || TREE_OVERFLOW (TYPE_SIZE (type)))))
2354     {
2355       ffebad_start (FFEBAD_ARRAY_LARGE);
2356       ffebad_string (ffesymbol_text (s));
2357       ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
2358       ffebad_finish ();
2359
2360       return error_mark_node;
2361     }
2362
2363   return type;
2364 }
2365 #endif
2366
2367 /* Builds a length argument (PARM_DECL).  Also wraps type in an array type
2368    where the dimension info is (1:size) where <size> is ffesymbol_size(s) if
2369    known, length_arg if not known (FFETARGET_charactersizeNONE).  */
2370
2371 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2372 static tree
2373 ffecom_char_enhance_arg_ (tree *xtype, ffesymbol s)
2374 {
2375   ffetargetCharacterSize sz = ffesymbol_size (s);
2376   tree highval;
2377   tree tlen;
2378   tree type = *xtype;
2379
2380   if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
2381     tlen = NULL_TREE;           /* A statement function, no length passed. */
2382   else
2383     {
2384       if (ffesymbol_where (s) == FFEINFO_whereDUMMY)
2385         tlen = ffecom_get_invented_identifier ("__g77_length_%s",
2386                                                ffesymbol_text (s));
2387       else
2388         tlen = ffecom_get_invented_identifier ("__g77_%s", "length");
2389       tlen = build_decl (PARM_DECL, tlen, ffecom_f2c_ftnlen_type_node);
2390 #if BUILT_FOR_270
2391       DECL_ARTIFICIAL (tlen) = 1;
2392 #endif
2393     }
2394
2395   if (sz == FFETARGET_charactersizeNONE)
2396     {
2397       assert (tlen != NULL_TREE);
2398       highval = variable_size (tlen);
2399     }
2400   else
2401     {
2402       highval = build_int_2 (sz, 0);
2403       TREE_TYPE (highval) = ffecom_f2c_ftnlen_type_node;
2404     }
2405
2406   type = build_array_type (type,
2407                            build_range_type (ffecom_f2c_ftnlen_type_node,
2408                                              ffecom_f2c_ftnlen_one_node,
2409                                              highval));
2410
2411   *xtype = type;
2412   return tlen;
2413 }
2414
2415 #endif
2416 /* ffecom_concat_list_gather_ -- Gather list of concatenated string exprs
2417
2418    ffecomConcatList_ catlist;
2419    ffebld expr;  // expr of CHARACTER basictype.
2420    ffetargetCharacterSize max;  // max chars to gather or _...NONE if no max
2421    catlist = ffecom_concat_list_gather_(catlist,expr,max);
2422
2423    Scans expr for character subexpressions, updates and returns catlist
2424    accordingly.  */
2425
2426 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2427 static ffecomConcatList_
2428 ffecom_concat_list_gather_ (ffecomConcatList_ catlist, ffebld expr,
2429                             ffetargetCharacterSize max)
2430 {
2431   ffetargetCharacterSize sz;
2432
2433 recurse:                        /* :::::::::::::::::::: */
2434
2435   if (expr == NULL)
2436     return catlist;
2437
2438   if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen >= max))
2439     return catlist;             /* Don't append any more items. */
2440
2441   switch (ffebld_op (expr))
2442     {
2443     case FFEBLD_opCONTER:
2444     case FFEBLD_opSYMTER:
2445     case FFEBLD_opARRAYREF:
2446     case FFEBLD_opFUNCREF:
2447     case FFEBLD_opSUBSTR:
2448     case FFEBLD_opCONVERT:      /* Callers should strip this off beforehand
2449                                    if they don't need to preserve it. */
2450       if (catlist.count == catlist.max)
2451         {                       /* Make a (larger) list. */
2452           ffebld *newx;
2453           int newmax;
2454
2455           newmax = (catlist.max == 0) ? 8 : catlist.max * 2;
2456           newx = malloc_new_ks (malloc_pool_image (), "catlist",
2457                                 newmax * sizeof (newx[0]));
2458           if (catlist.max != 0)
2459             {
2460               memcpy (newx, catlist.exprs, catlist.max * sizeof (newx[0]));
2461               malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2462                               catlist.max * sizeof (newx[0]));
2463             }
2464           catlist.max = newmax;
2465           catlist.exprs = newx;
2466         }
2467       if ((sz = ffebld_size_known (expr)) != FFETARGET_charactersizeNONE)
2468         catlist.minlen += sz;
2469       else
2470         ++catlist.minlen;       /* Not true for F90; can be 0 length. */
2471       if ((sz = ffebld_size_max (expr)) == FFETARGET_charactersizeNONE)
2472         catlist.maxlen = sz;
2473       else
2474         catlist.maxlen += sz;
2475       if ((max != FFETARGET_charactersizeNONE) && (catlist.minlen > max))
2476         {                       /* This item overlaps (or is beyond) the end
2477                                    of the destination. */
2478           switch (ffebld_op (expr))
2479             {
2480             case FFEBLD_opCONTER:
2481             case FFEBLD_opSYMTER:
2482             case FFEBLD_opARRAYREF:
2483             case FFEBLD_opFUNCREF:
2484             case FFEBLD_opSUBSTR:
2485               /* ~~Do useful truncations here. */
2486               break;
2487
2488             default:
2489               assert ("op changed or inconsistent switches!" == NULL);
2490               break;
2491             }
2492         }
2493       catlist.exprs[catlist.count++] = expr;
2494       return catlist;
2495
2496     case FFEBLD_opPAREN:
2497       expr = ffebld_left (expr);
2498       goto recurse;             /* :::::::::::::::::::: */
2499
2500     case FFEBLD_opCONCATENATE:
2501       catlist = ffecom_concat_list_gather_ (catlist, ffebld_left (expr), max);
2502       expr = ffebld_right (expr);
2503       goto recurse;             /* :::::::::::::::::::: */
2504
2505 #if 0                           /* Breaks passing small actual arg to larger
2506                                    dummy arg of sfunc */
2507     case FFEBLD_opCONVERT:
2508       expr = ffebld_left (expr);
2509       {
2510         ffetargetCharacterSize cmax;
2511
2512         cmax = catlist.len + ffebld_size_known (expr);
2513
2514         if ((max == FFETARGET_charactersizeNONE) || (max > cmax))
2515           max = cmax;
2516       }
2517       goto recurse;             /* :::::::::::::::::::: */
2518 #endif
2519
2520     case FFEBLD_opANY:
2521       return catlist;
2522
2523     default:
2524       assert ("bad op in _gather_" == NULL);
2525       return catlist;
2526     }
2527 }
2528
2529 #endif
2530 /* ffecom_concat_list_kill_ -- Kill list of concatenated string exprs
2531
2532    ffecomConcatList_ catlist;
2533    ffecom_concat_list_kill_(catlist);
2534
2535    Anything allocated within the list info is deallocated.  */
2536
2537 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2538 static void
2539 ffecom_concat_list_kill_ (ffecomConcatList_ catlist)
2540 {
2541   if (catlist.max != 0)
2542     malloc_kill_ks (malloc_pool_image (), catlist.exprs,
2543                     catlist.max * sizeof (catlist.exprs[0]));
2544 }
2545
2546 #endif
2547 /* Make list of concatenated string exprs.
2548
2549    Returns a flattened list of concatenated subexpressions given a
2550    tree of such expressions.  */
2551
2552 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2553 static ffecomConcatList_
2554 ffecom_concat_list_new_ (ffebld expr, ffetargetCharacterSize max)
2555 {
2556   ffecomConcatList_ catlist;
2557
2558   catlist.maxlen = catlist.minlen = catlist.max = catlist.count = 0;
2559   return ffecom_concat_list_gather_ (catlist, expr, max);
2560 }
2561
2562 #endif
2563
2564 /* Provide some kind of useful info on member of aggregate area,
2565    since current g77/gcc technology does not provide debug info
2566    on these members.  */
2567
2568 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2569 static void
2570 ffecom_debug_kludge_ (tree aggr, const char *aggr_type, ffesymbol member,
2571                       tree member_type UNUSED, ffetargetOffset offset)
2572 {
2573   tree value;
2574   tree decl;
2575   int len;
2576   char *buff;
2577   char space[120];
2578 #if 0
2579   tree type_id;
2580
2581   for (type_id = member_type;
2582        TREE_CODE (type_id) != IDENTIFIER_NODE;
2583        )
2584     {
2585       switch (TREE_CODE (type_id))
2586         {
2587         case INTEGER_TYPE:
2588         case REAL_TYPE:
2589           type_id = TYPE_NAME (type_id);
2590           break;
2591
2592         case ARRAY_TYPE:
2593         case COMPLEX_TYPE:
2594           type_id = TREE_TYPE (type_id);
2595           break;
2596
2597         default:
2598           assert ("no IDENTIFIER_NODE for type!" == NULL);
2599           type_id = error_mark_node;
2600           break;
2601         }
2602     }
2603 #endif
2604
2605   if (ffecom_transform_only_dummies_
2606       || !ffe_is_debug_kludge ())
2607     return;     /* Can't do this yet, maybe later. */
2608
2609   len = 60
2610     + strlen (aggr_type)
2611     + IDENTIFIER_LENGTH (DECL_NAME (aggr));
2612 #if 0
2613     + IDENTIFIER_LENGTH (type_id);
2614 #endif
2615
2616   if (((size_t) len) >= ARRAY_SIZE (space))
2617     buff = malloc_new_ks (malloc_pool_image (), "debug_kludge", len + 1);
2618   else
2619     buff = &space[0];
2620
2621   sprintf (&buff[0], "At (%s) `%s' plus %ld bytes",
2622            aggr_type,
2623            IDENTIFIER_POINTER (DECL_NAME (aggr)),
2624            (long int) offset);
2625
2626   value = build_string (len, buff);
2627   TREE_TYPE (value)
2628     = build_type_variant (build_array_type (char_type_node,
2629                                             build_range_type
2630                                             (integer_type_node,
2631                                              integer_one_node,
2632                                              build_int_2 (strlen (buff), 0))),
2633                           1, 0);
2634   decl = build_decl (VAR_DECL,
2635                      ffecom_get_identifier_ (ffesymbol_text (member)),
2636                      TREE_TYPE (value));
2637   TREE_CONSTANT (decl) = 1;
2638   TREE_STATIC (decl) = 1;
2639   DECL_INITIAL (decl) = error_mark_node;
2640   DECL_IN_SYSTEM_HEADER (decl) = 1;     /* Don't let -Wunused complain. */
2641   decl = start_decl (decl, FALSE);
2642   finish_decl (decl, value, FALSE);
2643
2644   if (buff != &space[0])
2645     malloc_kill_ks (malloc_pool_image (), buff, len + 1);
2646 }
2647 #endif
2648
2649 /* ffecom_do_entry_ -- Do compilation of a particular entrypoint
2650
2651    ffesymbol fn;  // the SUBROUTINE, FUNCTION, or ENTRY symbol itself
2652    int i;  // entry# for this entrypoint (used by master fn)
2653    ffecom_do_entrypoint_(s,i);
2654
2655    Makes a public entry point that calls our private master fn (already
2656    compiled).  */
2657
2658 #if FFECOM_targetCURRENT == FFECOM_targetGCC
2659 static void
2660 ffecom_do_entry_ (ffesymbol fn, int entrynum)
2661 {
2662   ffebld item;
2663   tree type;                    /* Type of function. */
2664   tree multi_retval;            /* Var holding return value (union). */
2665   tree result;                  /* Var holding result. */
2666   ffeinfoBasictype bt;
2667   ffeinfoKindtype kt;
2668   ffeglobal g;
2669   ffeglobalType gt;
2670   bool charfunc;                /* All entry points return same type
2671                                    CHARACTER. */
2672   bool cmplxfunc;               /* Use f2c way of returning COMPLEX. */
2673   bool multi;                   /* Master fn has multiple return types. */
2674   bool altreturning = FALSE;    /* This entry point has alternate returns. */
2675   int old_lineno = lineno;
2676   const char *old_input_filename = input_filename;
2677
2678   input_filename = ffesymbol_where_filename (fn);
2679   lineno = ffesymbol_where_filelinenum (fn);
2680
2681   ffecom_doing_entry_ = TRUE;   /* Don't bother with array dimensions. */
2682
2683   switch (ffecom_primary_entry_kind_)
2684     {
2685     case FFEINFO_kindFUNCTION:
2686
2687       /* Determine actual return type for function. */
2688
2689       gt = FFEGLOBAL_typeFUNC;
2690       bt = ffesymbol_basictype (fn);
2691       kt = ffesymbol_kindtype (fn);
2692       if (bt == FFEINFO_basictypeNONE)
2693         {
2694           ffeimplic_establish_symbol (fn);
2695           if (ffesymbol_funcresult (fn) != NULL)
2696             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
2697           bt = ffesymbol_basictype (fn);
2698           kt = ffesymbol_kindtype (fn);
2699         }
2700
2701       if (bt == FFEINFO_basictypeCHARACTER)
2702         charfunc = TRUE, cmplxfunc = FALSE;
2703       else if ((bt == FFEINFO_basictypeCOMPLEX)
2704                && ffesymbol_is_f2c (fn))
2705         charfunc = FALSE, cmplxfunc = TRUE;
2706       else
2707         charfunc = cmplxfunc = FALSE;
2708
2709       if (charfunc)
2710         type = ffecom_tree_fun_type_void;
2711       else if (ffesymbol_is_f2c (fn))
2712         type = ffecom_tree_fun_type[bt][kt];
2713       else
2714         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
2715
2716       if ((type == NULL_TREE)
2717           || (TREE_TYPE (type) == NULL_TREE))
2718         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
2719
2720       multi = (ffecom_master_bt_ == FFEINFO_basictypeNONE);
2721       break;
2722
2723     case FFEINFO_kindSUBROUTINE:
2724       gt = FFEGLOBAL_typeSUBR;
2725       bt = FFEINFO_basictypeNONE;
2726       kt = FFEINFO_kindtypeNONE;
2727       if (ffecom_is_altreturning_)
2728         {                       /* Am _I_ altreturning? */
2729           for (item = ffesymbol_dummyargs (fn);
2730                item != NULL;
2731                item = ffebld_trail (item))
2732             {
2733               if (ffebld_op (ffebld_head (item)) == FFEBLD_opSTAR)
2734                 {
2735                   altreturning = TRUE;
2736                   break;
2737                 }
2738             }
2739           if (altreturning)
2740             type = ffecom_tree_subr_type;
2741           else
2742             type = ffecom_tree_fun_type_void;
2743         }
2744       else
2745         type = ffecom_tree_fun_type_void;
2746       charfunc = FALSE;
2747       cmplxfunc = FALSE;
2748       multi = FALSE;
2749       break;
2750
2751     default:
2752       assert ("say what??" == NULL);
2753       /* Fall through. */
2754     case FFEINFO_kindANY:
2755       gt = FFEGLOBAL_typeANY;
2756       bt = FFEINFO_basictypeNONE;
2757       kt = FFEINFO_kindtypeNONE;
2758       type = error_mark_node;
2759       charfunc = FALSE;
2760       cmplxfunc = FALSE;
2761       multi = FALSE;
2762       break;
2763     }
2764
2765   /* build_decl uses the current lineno and input_filename to set the decl
2766      source info.  So, I've putzed with ffestd and ffeste code to update that
2767      source info to point to the appropriate statement just before calling
2768      ffecom_do_entrypoint (which calls this fn).  */
2769
2770   start_function (ffecom_get_external_identifier_ (fn),
2771                   type,
2772                   0,            /* nested/inline */
2773                   1);           /* TREE_PUBLIC */
2774
2775   if (((g = ffesymbol_global (fn)) != NULL)
2776       && ((ffeglobal_type (g) == gt)
2777           || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
2778     {
2779       ffeglobal_set_hook (g, current_function_decl);
2780     }
2781
2782   /* Reset args in master arg list so they get retransitioned. */
2783
2784   for (item = ffecom_master_arglist_;
2785        item != NULL;
2786        item = ffebld_trail (item))
2787     {
2788       ffebld arg;
2789       ffesymbol s;
2790
2791       arg = ffebld_head (item);
2792       if (ffebld_op (arg) != FFEBLD_opSYMTER)
2793         continue;               /* Alternate return or some such thing. */
2794       s = ffebld_symter (arg);
2795       ffesymbol_hook (s).decl_tree = NULL_TREE;
2796       ffesymbol_hook (s).length_tree = NULL_TREE;
2797     }
2798
2799   /* Build dummy arg list for this entry point. */
2800
2801   if (charfunc || cmplxfunc)
2802     {                           /* Prepend arg for where result goes. */
2803       tree type;
2804       tree length;
2805
2806       if (charfunc)
2807         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
2808       else
2809         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
2810
2811       result = ffecom_get_invented_identifier ("__g77_%s", "result");
2812
2813       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
2814
2815       if (charfunc)
2816         length = ffecom_char_enhance_arg_ (&type, fn);
2817       else
2818         length = NULL_TREE;     /* Not ref'd if !charfunc. */
2819
2820       type = build_pointer_type (type);
2821       result = build_decl (PARM_DECL, result, type);
2822
2823       push_parm_decl (result);
2824       ffecom_func_result_ = result;
2825
2826       if (charfunc)
2827         {
2828           push_parm_decl (length);
2829           ffecom_func_length_ = length;
2830         }
2831     }
2832   else
2833     result = DECL_RESULT (current_function_decl);
2834
2835   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (fn), FALSE);
2836
2837   store_parm_decls (0);
2838
2839   ffecom_start_compstmt ();
2840   /* Disallow temp vars at this level.  */
2841   current_binding_level->prep_state = 2;
2842
2843   /* Make local var to hold return type for multi-type master fn. */
2844
2845   if (multi)
2846     {
2847       multi_retval = ffecom_get_invented_identifier ("__g77_%s",
2848                                                      "multi_retval");
2849       multi_retval = build_decl (VAR_DECL, multi_retval,
2850                                  ffecom_multi_type_node_);
2851       multi_retval = start_decl (multi_retval, FALSE);
2852       finish_decl (multi_retval, NULL_TREE, FALSE);
2853     }
2854   else
2855     multi_retval = NULL_TREE;   /* Not actually ref'd if !multi. */
2856
2857   /* Here we emit the actual code for the entry point. */
2858
2859   {
2860     ffebld list;
2861     ffebld arg;
2862     ffesymbol s;
2863     tree arglist = NULL_TREE;
2864     tree *plist = &arglist;
2865     tree prepend;
2866     tree call;
2867     tree actarg;
2868     tree master_fn;
2869
2870     /* Prepare actual arg list based on master arg list. */
2871
2872     for (list = ffecom_master_arglist_;
2873          list != NULL;
2874          list = ffebld_trail (list))
2875       {
2876         arg = ffebld_head (list);
2877         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2878           continue;
2879         s = ffebld_symter (arg);
2880         if (ffesymbol_hook (s).decl_tree == NULL_TREE
2881             || ffesymbol_hook (s).decl_tree == error_mark_node)
2882           actarg = null_pointer_node;   /* We don't have this arg. */
2883         else
2884           actarg = ffesymbol_hook (s).decl_tree;
2885         *plist = build_tree_list (NULL_TREE, actarg);
2886         plist = &TREE_CHAIN (*plist);
2887       }
2888
2889     /* This code appends the length arguments for character
2890        variables/arrays.  */
2891
2892     for (list = ffecom_master_arglist_;
2893          list != NULL;
2894          list = ffebld_trail (list))
2895       {
2896         arg = ffebld_head (list);
2897         if (ffebld_op (arg) != FFEBLD_opSYMTER)
2898           continue;
2899         s = ffebld_symter (arg);
2900         if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
2901           continue;             /* Only looking for CHARACTER arguments. */
2902         if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
2903           continue;             /* Only looking for variables and arrays. */
2904         if (ffesymbol_hook (s).length_tree == NULL_TREE
2905             || ffesymbol_hook (s).length_tree == error_mark_node)
2906           actarg = ffecom_f2c_ftnlen_zero_node; /* We don't have this arg. */
2907         else
2908           actarg = ffesymbol_hook (s).length_tree;
2909         *plist = build_tree_list (NULL_TREE, actarg);
2910         plist = &TREE_CHAIN (*plist);
2911       }
2912
2913     /* Prepend character-value return info to actual arg list. */
2914
2915     if (charfunc)
2916       {
2917         prepend = build_tree_list (NULL_TREE, ffecom_func_result_);
2918         TREE_CHAIN (prepend)
2919           = build_tree_list (NULL_TREE, ffecom_func_length_);
2920         TREE_CHAIN (TREE_CHAIN (prepend)) = arglist;
2921         arglist = prepend;
2922       }
2923
2924     /* Prepend multi-type return value to actual arg list. */
2925
2926     if (multi)
2927       {
2928         prepend
2929           = build_tree_list (NULL_TREE,
2930                              ffecom_1 (ADDR_EXPR,
2931                               build_pointer_type (TREE_TYPE (multi_retval)),
2932                                        multi_retval));
2933         TREE_CHAIN (prepend) = arglist;
2934         arglist = prepend;
2935       }
2936
2937     /* Prepend my entry-point number to the actual arg list. */
2938
2939     prepend = build_tree_list (NULL_TREE, build_int_2 (entrynum, 0));
2940     TREE_CHAIN (prepend) = arglist;
2941     arglist = prepend;
2942
2943     /* Build the call to the master function. */
2944
2945     master_fn = ffecom_1_fn (ffecom_previous_function_decl_);
2946     call = ffecom_3s (CALL_EXPR,
2947                       TREE_TYPE (TREE_TYPE (TREE_TYPE (master_fn))),
2948                       master_fn, arglist, NULL_TREE);
2949
2950     /* Decide whether the master function is a function or subroutine, and
2951        handle the return value for my entry point. */
2952
2953     if (charfunc || ((ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
2954                      && !altreturning))
2955       {
2956         expand_expr_stmt (call);
2957         expand_null_return ();
2958       }
2959     else if (multi && cmplxfunc)
2960       {
2961         expand_expr_stmt (call);
2962         result
2963           = ffecom_1 (INDIRECT_REF,
2964                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2965                       result);
2966         result = ffecom_modify (NULL_TREE, result,
2967                                 ffecom_2 (COMPONENT_REF, TREE_TYPE (result),
2968                                           multi_retval,
2969                                           ffecom_multi_fields_[bt][kt]));
2970         expand_expr_stmt (result);
2971         expand_null_return ();
2972       }
2973     else if (multi)
2974       {
2975         expand_expr_stmt (call);
2976         result
2977           = ffecom_modify (NULL_TREE, result,
2978                            convert (TREE_TYPE (result),
2979                                     ffecom_2 (COMPONENT_REF,
2980                                               ffecom_tree_type[bt][kt],
2981                                               multi_retval,
2982                                               ffecom_multi_fields_[bt][kt])));
2983         expand_return (result);
2984       }
2985     else if (cmplxfunc)
2986       {
2987         result
2988           = ffecom_1 (INDIRECT_REF,
2989                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (result))),
2990                       result);
2991         result = ffecom_modify (NULL_TREE, result, call);
2992         expand_expr_stmt (result);
2993         expand_null_return ();
2994       }
2995     else
2996       {
2997         result = ffecom_modify (NULL_TREE,
2998                                 result,
2999                                 convert (TREE_TYPE (result),
3000                                          call));
3001         expand_return (result);
3002       }
3003   }
3004
3005   ffecom_end_compstmt ();
3006
3007   finish_function (0);
3008
3009   lineno = old_lineno;
3010   input_filename = old_input_filename;
3011
3012   ffecom_doing_entry_ = FALSE;
3013 }
3014
3015 #endif
3016 /* Transform expr into gcc tree with possible destination
3017
3018    Recursive descent on expr while making corresponding tree nodes and
3019    attaching type info and such.  If destination supplied and compatible
3020    with temporary that would be made in certain cases, temporary isn't
3021    made, destination used instead, and dest_used flag set TRUE.  */
3022
3023 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3024 static tree
3025 ffecom_expr_ (ffebld expr, tree dest_tree, ffebld dest,
3026               bool *dest_used, bool assignp, bool widenp)
3027 {
3028   tree item;
3029   tree list;
3030   tree args;
3031   ffeinfoBasictype bt;
3032   ffeinfoKindtype kt;
3033   tree t;
3034   tree dt;                      /* decl_tree for an ffesymbol. */
3035   tree tree_type, tree_type_x;
3036   tree left, right;
3037   ffesymbol s;
3038   enum tree_code code;
3039
3040   assert (expr != NULL);
3041
3042   if (dest_used != NULL)
3043     *dest_used = FALSE;
3044
3045   bt = ffeinfo_basictype (ffebld_info (expr));
3046   kt = ffeinfo_kindtype (ffebld_info (expr));
3047   tree_type = ffecom_tree_type[bt][kt];
3048
3049   /* Widen integral arithmetic as desired while preserving signedness.  */
3050   tree_type_x = NULL_TREE;
3051   if (widenp && tree_type
3052       && GET_MODE_CLASS (TYPE_MODE (tree_type)) == MODE_INT
3053       && TYPE_PRECISION (tree_type) < TYPE_PRECISION (sizetype))
3054     tree_type_x = (TREE_UNSIGNED (tree_type) ? usizetype : ssizetype);
3055
3056   switch (ffebld_op (expr))
3057     {
3058     case FFEBLD_opACCTER:
3059       {
3060         ffebitCount i;
3061         ffebit bits = ffebld_accter_bits (expr);
3062         ffetargetOffset source_offset = 0;
3063         ffetargetOffset dest_offset = ffebld_accter_pad (expr);
3064         tree purpose;
3065
3066         assert (dest_offset == 0
3067                 || (bt == FFEINFO_basictypeCHARACTER
3068                     && kt == FFEINFO_kindtypeCHARACTER1));
3069
3070         list = item = NULL;
3071         for (;;)
3072           {
3073             ffebldConstantUnion cu;
3074             ffebitCount length;
3075             bool value;
3076             ffebldConstantArray ca = ffebld_accter (expr);
3077
3078             ffebit_test (bits, source_offset, &value, &length);
3079             if (length == 0)
3080               break;
3081
3082             if (value)
3083               {
3084                 for (i = 0; i < length; ++i)
3085                   {
3086                     cu = ffebld_constantarray_get (ca, bt, kt,
3087                                                    source_offset + i);
3088
3089                     t = ffecom_constantunion (&cu, bt, kt, tree_type);
3090
3091                     if (i == 0
3092                         && dest_offset != 0)
3093                       purpose = build_int_2 (dest_offset, 0);
3094                     else
3095                       purpose = NULL_TREE;
3096
3097                     if (list == NULL_TREE)
3098                       list = item = build_tree_list (purpose, t);
3099                     else
3100                       {
3101                         TREE_CHAIN (item) = build_tree_list (purpose, t);
3102                         item = TREE_CHAIN (item);
3103                       }
3104                   }
3105               }
3106             source_offset += length;
3107             dest_offset += length;
3108           }
3109       }
3110
3111       item = build_int_2 ((ffebld_accter_size (expr)
3112                            + ffebld_accter_pad (expr)) - 1, 0);
3113       ffebit_kill (ffebld_accter_bits (expr));
3114       TREE_TYPE (item) = ffecom_integer_type_node;
3115       item
3116         = build_array_type
3117           (tree_type,
3118            build_range_type (ffecom_integer_type_node,
3119                              ffecom_integer_zero_node,
3120                              item));
3121       list = build (CONSTRUCTOR, item, NULL_TREE, list);
3122       TREE_CONSTANT (list) = 1;
3123       TREE_STATIC (list) = 1;
3124       return list;
3125
3126     case FFEBLD_opARRTER:
3127       {
3128         ffetargetOffset i;
3129
3130         list = NULL_TREE;
3131         if (ffebld_arrter_pad (expr) == 0)
3132           item = NULL_TREE;
3133         else
3134           {
3135             assert (bt == FFEINFO_basictypeCHARACTER
3136                     && kt == FFEINFO_kindtypeCHARACTER1);
3137
3138             /* Becomes PURPOSE first time through loop.  */
3139             item = build_int_2 (ffebld_arrter_pad (expr), 0);
3140           }
3141
3142         for (i = 0; i < ffebld_arrter_size (expr); ++i)
3143           {
3144             ffebldConstantUnion cu
3145             = ffebld_constantarray_get (ffebld_arrter (expr), bt, kt, i);
3146
3147             t = ffecom_constantunion (&cu, bt, kt, tree_type);
3148
3149             if (list == NULL_TREE)
3150               /* Assume item is PURPOSE first time through loop.  */
3151               list = item = build_tree_list (item, t);
3152             else
3153               {
3154                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
3155                 item = TREE_CHAIN (item);
3156               }
3157           }
3158       }
3159
3160       item = build_int_2 ((ffebld_arrter_size (expr)
3161                           + ffebld_arrter_pad (expr)) - 1, 0);
3162       TREE_TYPE (item) = ffecom_integer_type_node;
3163       item
3164         = build_array_type
3165           (tree_type,
3166            build_range_type (ffecom_integer_type_node,
3167                              ffecom_integer_zero_node,
3168                              item));
3169       list = build (CONSTRUCTOR, item, NULL_TREE, list);
3170       TREE_CONSTANT (list) = 1;
3171       TREE_STATIC (list) = 1;
3172       return list;
3173
3174     case FFEBLD_opCONTER:
3175       assert (ffebld_conter_pad (expr) == 0);
3176       item
3177         = ffecom_constantunion (&ffebld_constant_union (ffebld_conter (expr)),
3178                                 bt, kt, tree_type);
3179       return item;
3180
3181     case FFEBLD_opSYMTER:
3182       if ((ffebld_symter_generic (expr) != FFEINTRIN_genNONE)
3183           || (ffebld_symter_specific (expr) != FFEINTRIN_specNONE))
3184         return ffecom_ptr_to_expr (expr);       /* Same as %REF(intrinsic). */
3185       s = ffebld_symter (expr);
3186       t = ffesymbol_hook (s).decl_tree;
3187
3188       if (assignp)
3189         {                       /* ASSIGN'ed-label expr. */
3190           if (ffe_is_ugly_assign ())
3191             {
3192               /* User explicitly wants ASSIGN'ed variables to be at the same
3193                  memory address as the variables when used in non-ASSIGN
3194                  contexts.  That can make old, arcane, non-standard code
3195                  work, but don't try to do it when a pointer wouldn't fit
3196                  in the normal variable (take other approach, and warn,
3197                  instead).  */
3198
3199               if (t == NULL_TREE)
3200                 {
3201                   s = ffecom_sym_transform_ (s);
3202                   t = ffesymbol_hook (s).decl_tree;
3203                   assert (t != NULL_TREE);
3204                 }
3205
3206               if (t == error_mark_node)
3207                 return t;
3208
3209               if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (t)))
3210                   >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
3211                 {
3212                   if (ffesymbol_hook (s).addr)
3213                     t = ffecom_1 (INDIRECT_REF,
3214                                   TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3215                   return t;
3216                 }
3217
3218               if (ffesymbol_hook (s).assign_tree == NULL_TREE)
3219                 {
3220                   ffebad_start_msg ("ASSIGN'ed label cannot fit into `%A' at %0 -- using wider sibling",
3221                                     FFEBAD_severityWARNING);
3222                   ffebad_string (ffesymbol_text (s));
3223                   ffebad_here (0, ffesymbol_where_line (s),
3224                                ffesymbol_where_column (s));
3225                   ffebad_finish ();
3226                 }
3227             }
3228
3229           /* Don't use the normal variable's tree for ASSIGN, though mark
3230              it as in the system header (housekeeping).  Use an explicit,
3231              specially created sibling that is known to be wide enough
3232              to hold pointers to labels.  */
3233
3234           if (t != NULL_TREE
3235               && TREE_CODE (t) == VAR_DECL)
3236             DECL_IN_SYSTEM_HEADER (t) = 1;      /* Don't let -Wunused complain. */
3237
3238           t = ffesymbol_hook (s).assign_tree;
3239           if (t == NULL_TREE)
3240             {
3241               s = ffecom_sym_transform_assign_ (s);
3242               t = ffesymbol_hook (s).assign_tree;
3243               assert (t != NULL_TREE);
3244             }
3245         }
3246       else
3247         {
3248           if (t == NULL_TREE)
3249             {
3250               s = ffecom_sym_transform_ (s);
3251               t = ffesymbol_hook (s).decl_tree;
3252               assert (t != NULL_TREE);
3253             }
3254           if (ffesymbol_hook (s).addr)
3255             t = ffecom_1 (INDIRECT_REF,
3256                           TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (t))), t);
3257         }
3258       return t;
3259
3260     case FFEBLD_opARRAYREF:
3261       return ffecom_arrayref_ (NULL_TREE, expr, 0);
3262
3263     case FFEBLD_opUPLUS:
3264       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3265       return ffecom_1 (NOP_EXPR, tree_type, left);
3266
3267     case FFEBLD_opPAREN:
3268       /* ~~~Make sure Fortran rules respected here */
3269       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3270       return ffecom_1 (NOP_EXPR, tree_type, left);
3271
3272     case FFEBLD_opUMINUS:
3273       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3274       if (tree_type_x)
3275         {
3276           tree_type = tree_type_x;
3277           left = convert (tree_type, left);
3278         }
3279       return ffecom_1 (NEGATE_EXPR, tree_type, left);
3280
3281     case FFEBLD_opADD:
3282       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3283       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3284       if (tree_type_x)
3285         {
3286           tree_type = tree_type_x;
3287           left = convert (tree_type, left);
3288           right = convert (tree_type, right);
3289         }
3290       return ffecom_2 (PLUS_EXPR, tree_type, left, right);
3291
3292     case FFEBLD_opSUBTRACT:
3293       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3294       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3295       if (tree_type_x)
3296         {
3297           tree_type = tree_type_x;
3298           left = convert (tree_type, left);
3299           right = convert (tree_type, right);
3300         }
3301       return ffecom_2 (MINUS_EXPR, tree_type, left, right);
3302
3303     case FFEBLD_opMULTIPLY:
3304       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3305       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3306       if (tree_type_x)
3307         {
3308           tree_type = tree_type_x;
3309           left = convert (tree_type, left);
3310           right = convert (tree_type, right);
3311         }
3312       return ffecom_2 (MULT_EXPR, tree_type, left, right);
3313
3314     case FFEBLD_opDIVIDE:
3315       left = ffecom_expr_ (ffebld_left (expr), NULL, NULL, NULL, FALSE, widenp);
3316       right = ffecom_expr_ (ffebld_right (expr), NULL, NULL, NULL, FALSE, widenp);
3317       if (tree_type_x)
3318         {
3319           tree_type = tree_type_x;
3320           left = convert (tree_type, left);
3321           right = convert (tree_type, right);
3322         }
3323       return ffecom_tree_divide_ (tree_type, left, right,
3324                                   dest_tree, dest, dest_used,
3325                                   ffebld_nonter_hook (expr));
3326
3327     case FFEBLD_opPOWER:
3328       {
3329         ffebld left = ffebld_left (expr);
3330         ffebld right = ffebld_right (expr);
3331         ffecomGfrt code;
3332         ffeinfoKindtype rtkt;
3333         ffeinfoKindtype ltkt;
3334         bool ref = TRUE;
3335
3336         switch (ffeinfo_basictype (ffebld_info (right)))
3337           {
3338
3339           case FFEINFO_basictypeINTEGER:
3340             if (1 || optimize)
3341               {
3342                 item = ffecom_expr_power_integer_ (expr);
3343                 if (item != NULL_TREE)
3344                   return item;
3345               }
3346
3347             rtkt = FFEINFO_kindtypeINTEGER1;
3348             switch (ffeinfo_basictype (ffebld_info (left)))
3349               {
3350               case FFEINFO_basictypeINTEGER:
3351                 if ((ffeinfo_kindtype (ffebld_info (left))
3352                     == FFEINFO_kindtypeINTEGER4)
3353                     || (ffeinfo_kindtype (ffebld_info (right))
3354                         == FFEINFO_kindtypeINTEGER4))
3355                   {
3356                     code = FFECOM_gfrtPOW_QQ;
3357                     ltkt = FFEINFO_kindtypeINTEGER4;
3358                     rtkt = FFEINFO_kindtypeINTEGER4;
3359                   }
3360                 else
3361                   {
3362                     code = FFECOM_gfrtPOW_II;
3363                     ltkt = FFEINFO_kindtypeINTEGER1;
3364                   }
3365                 break;
3366
3367               case FFEINFO_basictypeREAL:
3368                 if (ffeinfo_kindtype (ffebld_info (left))
3369                     == FFEINFO_kindtypeREAL1)
3370                   {
3371                     code = FFECOM_gfrtPOW_RI;
3372                     ltkt = FFEINFO_kindtypeREAL1;
3373                   }
3374                 else
3375                   {
3376                     code = FFECOM_gfrtPOW_DI;
3377                     ltkt = FFEINFO_kindtypeREAL2;
3378                   }
3379                 break;
3380
3381               case FFEINFO_basictypeCOMPLEX:
3382                 if (ffeinfo_kindtype (ffebld_info (left))
3383                     == FFEINFO_kindtypeREAL1)
3384                   {
3385                     code = FFECOM_gfrtPOW_CI;   /* Overlapping result okay. */
3386                     ltkt = FFEINFO_kindtypeREAL1;
3387                   }
3388                 else
3389                   {
3390                     code = FFECOM_gfrtPOW_ZI;   /* Overlapping result okay. */
3391                     ltkt = FFEINFO_kindtypeREAL2;
3392                   }
3393                 break;
3394
3395               default:
3396                 assert ("bad pow_*i" == NULL);
3397                 code = FFECOM_gfrtPOW_CI;       /* Overlapping result okay. */
3398                 ltkt = FFEINFO_kindtypeREAL1;
3399                 break;
3400               }
3401             if (ffeinfo_kindtype (ffebld_info (left)) != ltkt)
3402               left = ffeexpr_convert (left, NULL, NULL,
3403                                       ffeinfo_basictype (ffebld_info (left)),
3404                                       ltkt, 0,
3405                                       FFETARGET_charactersizeNONE,
3406                                       FFEEXPR_contextLET);
3407             if (ffeinfo_kindtype (ffebld_info (right)) != rtkt)
3408               right = ffeexpr_convert (right, NULL, NULL,
3409                                        FFEINFO_basictypeINTEGER,
3410                                        rtkt, 0,
3411                                        FFETARGET_charactersizeNONE,
3412                                        FFEEXPR_contextLET);
3413             break;
3414
3415           case FFEINFO_basictypeREAL:
3416             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3417               left = ffeexpr_convert (left, NULL, NULL, FFEINFO_basictypeREAL,
3418                                       FFEINFO_kindtypeREALDOUBLE, 0,
3419                                       FFETARGET_charactersizeNONE,
3420                                       FFEEXPR_contextLET);
3421             if (ffeinfo_kindtype (ffebld_info (right))
3422                 == FFEINFO_kindtypeREAL1)
3423               right = ffeexpr_convert (right, NULL, NULL,
3424                                        FFEINFO_basictypeREAL,
3425                                        FFEINFO_kindtypeREALDOUBLE, 0,
3426                                        FFETARGET_charactersizeNONE,
3427                                        FFEEXPR_contextLET);
3428             /* We used to call FFECOM_gfrtPOW_DD here,
3429                which passes arguments by reference.  */
3430             code = FFECOM_gfrtL_POW;
3431             /* Pass arguments by value. */
3432             ref  = FALSE;
3433             break;
3434
3435           case FFEINFO_basictypeCOMPLEX:
3436             if (ffeinfo_kindtype (ffebld_info (left)) == FFEINFO_kindtypeREAL1)
3437               left = ffeexpr_convert (left, NULL, NULL,
3438                                       FFEINFO_basictypeCOMPLEX,
3439                                       FFEINFO_kindtypeREALDOUBLE, 0,
3440                                       FFETARGET_charactersizeNONE,
3441                                       FFEEXPR_contextLET);
3442             if (ffeinfo_kindtype (ffebld_info (right))
3443                 == FFEINFO_kindtypeREAL1)
3444               right = ffeexpr_convert (right, NULL, NULL,
3445                                        FFEINFO_basictypeCOMPLEX,
3446                                        FFEINFO_kindtypeREALDOUBLE, 0,
3447                                        FFETARGET_charactersizeNONE,
3448                                        FFEEXPR_contextLET);
3449             code = FFECOM_gfrtPOW_ZZ;   /* Overlapping result okay. */
3450             ref = TRUE;                 /* Pass arguments by reference. */
3451             break;
3452
3453           default:
3454             assert ("bad pow_x*" == NULL);
3455             code = FFECOM_gfrtPOW_II;
3456             break;
3457           }
3458         return ffecom_call_binop_ (ffecom_gfrt_tree_ (code),
3459                                    ffecom_gfrt_kindtype (code),
3460                                    (ffe_is_f2c_library ()
3461                                     && ffecom_gfrt_complex_[code]),
3462                                    tree_type, left, right,
3463                                    dest_tree, dest, dest_used,
3464                                    NULL_TREE, FALSE, ref,
3465                                    ffebld_nonter_hook (expr));
3466       }
3467
3468     case FFEBLD_opNOT:
3469       switch (bt)
3470         {
3471         case FFEINFO_basictypeLOGICAL:
3472           item = ffecom_truth_value_invert (ffecom_expr (ffebld_left (expr)));
3473           return convert (tree_type, item);
3474
3475         case FFEINFO_basictypeINTEGER:
3476           return ffecom_1 (BIT_NOT_EXPR, tree_type,
3477                            ffecom_expr (ffebld_left (expr)));
3478
3479         default:
3480           assert ("NOT bad basictype" == NULL);
3481           /* Fall through. */
3482         case FFEINFO_basictypeANY:
3483           return error_mark_node;
3484         }
3485       break;
3486
3487     case FFEBLD_opFUNCREF:
3488       assert (ffeinfo_basictype (ffebld_info (expr))
3489               != FFEINFO_basictypeCHARACTER);
3490       /* Fall through.   */
3491     case FFEBLD_opSUBRREF:
3492       if (ffeinfo_where (ffebld_info (ffebld_left (expr)))
3493           == FFEINFO_whereINTRINSIC)
3494         {                       /* Invocation of an intrinsic. */
3495           item = ffecom_expr_intrinsic_ (expr, dest_tree, dest,
3496                                          dest_used);
3497           return item;
3498         }
3499       s = ffebld_symter (ffebld_left (expr));
3500       dt = ffesymbol_hook (s).decl_tree;
3501       if (dt == NULL_TREE)
3502         {
3503           s = ffecom_sym_transform_ (s);
3504           dt = ffesymbol_hook (s).decl_tree;
3505         }
3506       if (dt == error_mark_node)
3507         return dt;
3508
3509       if (ffesymbol_hook (s).addr)
3510         item = dt;
3511       else
3512         item = ffecom_1_fn (dt);
3513
3514       if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
3515         args = ffecom_list_expr (ffebld_right (expr));
3516       else
3517         args = ffecom_list_ptr_to_expr (ffebld_right (expr));
3518
3519       if (args == error_mark_node)
3520         return error_mark_node;
3521
3522       item = ffecom_call_ (item, kt,
3523                            ffesymbol_is_f2c (s)
3524                            && (bt == FFEINFO_basictypeCOMPLEX)
3525                            && (ffesymbol_where (s)
3526                                != FFEINFO_whereCONSTANT),
3527                            tree_type,
3528                            args,
3529                            dest_tree, dest, dest_used,
3530                            error_mark_node, FALSE,
3531                            ffebld_nonter_hook (expr));
3532       TREE_SIDE_EFFECTS (item) = 1;
3533       return item;
3534
3535     case FFEBLD_opAND:
3536       switch (bt)
3537         {
3538         case FFEINFO_basictypeLOGICAL:
3539           item
3540             = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3541                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3542                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3543           return convert (tree_type, item);
3544
3545         case FFEINFO_basictypeINTEGER:
3546           return ffecom_2 (BIT_AND_EXPR, tree_type,
3547                            ffecom_expr (ffebld_left (expr)),
3548                            ffecom_expr (ffebld_right (expr)));
3549
3550         default:
3551           assert ("AND bad basictype" == NULL);
3552           /* Fall through. */
3553         case FFEINFO_basictypeANY:
3554           return error_mark_node;
3555         }
3556       break;
3557
3558     case FFEBLD_opOR:
3559       switch (bt)
3560         {
3561         case FFEINFO_basictypeLOGICAL:
3562           item
3563             = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
3564                        ffecom_truth_value (ffecom_expr (ffebld_left (expr))),
3565                      ffecom_truth_value (ffecom_expr (ffebld_right (expr))));
3566           return convert (tree_type, item);
3567
3568         case FFEINFO_basictypeINTEGER:
3569           return ffecom_2 (BIT_IOR_EXPR, tree_type,
3570                            ffecom_expr (ffebld_left (expr)),
3571                            ffecom_expr (ffebld_right (expr)));
3572
3573         default:
3574           assert ("OR bad basictype" == NULL);
3575           /* Fall through. */
3576         case FFEINFO_basictypeANY:
3577           return error_mark_node;
3578         }
3579       break;
3580
3581     case FFEBLD_opXOR:
3582     case FFEBLD_opNEQV:
3583       switch (bt)
3584         {
3585         case FFEINFO_basictypeLOGICAL:
3586           item
3587             = ffecom_2 (NE_EXPR, integer_type_node,
3588                         ffecom_expr (ffebld_left (expr)),
3589                         ffecom_expr (ffebld_right (expr)));
3590           return convert (tree_type, ffecom_truth_value (item));
3591
3592         case FFEINFO_basictypeINTEGER:
3593           return ffecom_2 (BIT_XOR_EXPR, tree_type,
3594                            ffecom_expr (ffebld_left (expr)),
3595                            ffecom_expr (ffebld_right (expr)));
3596
3597         default:
3598           assert ("XOR/NEQV bad basictype" == NULL);
3599           /* Fall through. */
3600         case FFEINFO_basictypeANY:
3601           return error_mark_node;
3602         }
3603       break;
3604
3605     case FFEBLD_opEQV:
3606       switch (bt)
3607         {
3608         case FFEINFO_basictypeLOGICAL:
3609           item
3610             = ffecom_2 (EQ_EXPR, integer_type_node,
3611                         ffecom_expr (ffebld_left (expr)),
3612                         ffecom_expr (ffebld_right (expr)));
3613           return convert (tree_type, ffecom_truth_value (item));
3614
3615         case FFEINFO_basictypeINTEGER:
3616           return
3617             ffecom_1 (BIT_NOT_EXPR, tree_type,
3618                       ffecom_2 (BIT_XOR_EXPR, tree_type,
3619                                 ffecom_expr (ffebld_left (expr)),
3620                                 ffecom_expr (ffebld_right (expr))));
3621
3622         default:
3623           assert ("EQV bad basictype" == NULL);
3624           /* Fall through. */
3625         case FFEINFO_basictypeANY:
3626           return error_mark_node;
3627         }
3628       break;
3629
3630     case FFEBLD_opCONVERT:
3631       if (ffebld_op (ffebld_left (expr)) == FFEBLD_opANY)
3632         return error_mark_node;
3633
3634       switch (bt)
3635         {
3636         case FFEINFO_basictypeLOGICAL:
3637         case FFEINFO_basictypeINTEGER:
3638         case FFEINFO_basictypeREAL:
3639           return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3640
3641         case FFEINFO_basictypeCOMPLEX:
3642           switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3643             {
3644             case FFEINFO_basictypeINTEGER:
3645             case FFEINFO_basictypeLOGICAL:
3646             case FFEINFO_basictypeREAL:
3647               item = ffecom_expr (ffebld_left (expr));
3648               if (item == error_mark_node)
3649                 return error_mark_node;
3650               /* convert() takes care of converting to the subtype first,
3651                  at least in gcc-2.7.2. */
3652               item = convert (tree_type, item);
3653               return item;
3654
3655             case FFEINFO_basictypeCOMPLEX:
3656               return convert (tree_type, ffecom_expr (ffebld_left (expr)));
3657
3658             default:
3659               assert ("CONVERT COMPLEX bad basictype" == NULL);
3660               /* Fall through. */
3661             case FFEINFO_basictypeANY:
3662               return error_mark_node;
3663             }
3664           break;
3665
3666         default:
3667           assert ("CONVERT bad basictype" == NULL);
3668           /* Fall through. */
3669         case FFEINFO_basictypeANY:
3670           return error_mark_node;
3671         }
3672       break;
3673
3674     case FFEBLD_opLT:
3675       code = LT_EXPR;
3676       goto relational;          /* :::::::::::::::::::: */
3677
3678     case FFEBLD_opLE:
3679       code = LE_EXPR;
3680       goto relational;          /* :::::::::::::::::::: */
3681
3682     case FFEBLD_opEQ:
3683       code = EQ_EXPR;
3684       goto relational;          /* :::::::::::::::::::: */
3685
3686     case FFEBLD_opNE:
3687       code = NE_EXPR;
3688       goto relational;          /* :::::::::::::::::::: */
3689
3690     case FFEBLD_opGT:
3691       code = GT_EXPR;
3692       goto relational;          /* :::::::::::::::::::: */
3693
3694     case FFEBLD_opGE:
3695       code = GE_EXPR;
3696
3697     relational:         /* :::::::::::::::::::: */
3698       switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
3699         {
3700         case FFEINFO_basictypeLOGICAL:
3701         case FFEINFO_basictypeINTEGER:
3702         case FFEINFO_basictypeREAL:
3703           item = ffecom_2 (code, integer_type_node,
3704                            ffecom_expr (ffebld_left (expr)),
3705                            ffecom_expr (ffebld_right (expr)));
3706           return convert (tree_type, item);
3707
3708         case FFEINFO_basictypeCOMPLEX:
3709           assert (code == EQ_EXPR || code == NE_EXPR);
3710           {
3711             tree real_type;
3712             tree arg1 = ffecom_expr (ffebld_left (expr));
3713             tree arg2 = ffecom_expr (ffebld_right (expr));
3714
3715             if (arg1 == error_mark_node || arg2 == error_mark_node)
3716               return error_mark_node;
3717
3718             arg1 = ffecom_save_tree (arg1);
3719             arg2 = ffecom_save_tree (arg2);
3720
3721             if (TREE_CODE (TREE_TYPE (arg1)) == COMPLEX_TYPE)
3722               {
3723                 real_type = TREE_TYPE (TREE_TYPE (arg1));
3724                 assert (real_type == TREE_TYPE (TREE_TYPE (arg2)));
3725               }
3726             else
3727               {
3728                 real_type = TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg1)));
3729                 assert (real_type == TREE_TYPE (TYPE_FIELDS (TREE_TYPE (arg2))));
3730               }
3731
3732             item
3733               = ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
3734                           ffecom_2 (EQ_EXPR, integer_type_node,
3735                                   ffecom_1 (REALPART_EXPR, real_type, arg1),
3736                                  ffecom_1 (REALPART_EXPR, real_type, arg2)),
3737                           ffecom_2 (EQ_EXPR, integer_type_node,
3738                                   ffecom_1 (IMAGPART_EXPR, real_type, arg1),
3739                                     ffecom_1 (IMAGPART_EXPR, real_type,
3740                                               arg2)));
3741             if (code == EQ_EXPR)
3742               item = ffecom_truth_value (item);
3743             else
3744               item = ffecom_truth_value_invert (item);
3745             return convert (tree_type, item);
3746           }
3747
3748         case FFEINFO_basictypeCHARACTER:
3749           {
3750             ffebld left = ffebld_left (expr);
3751             ffebld right = ffebld_right (expr);
3752             tree left_tree;
3753             tree right_tree;
3754             tree left_length;
3755             tree right_length;
3756
3757             /* f2c run-time functions do the implicit blank-padding for us,
3758                so we don't usually have to implement blank-padding ourselves.
3759                (The exception is when we pass an argument to a separately
3760                compiled statement function -- if we know the arg is not the
3761                same length as the dummy, we must truncate or extend it.  If
3762                we "inline" statement functions, that necessity goes away as
3763                well.)
3764
3765                Strip off the CONVERT operators that blank-pad.  (Truncation by
3766                CONVERT shouldn't happen here, but it can happen in
3767                assignments.) */
3768
3769             while (ffebld_op (left) == FFEBLD_opCONVERT)
3770               left = ffebld_left (left);
3771             while (ffebld_op (right) == FFEBLD_opCONVERT)
3772               right = ffebld_left (right);
3773
3774             left_tree = ffecom_arg_ptr_to_expr (left, &left_length);
3775             right_tree = ffecom_arg_ptr_to_expr (right, &right_length);
3776
3777             if (left_tree == error_mark_node || left_length == error_mark_node
3778                 || right_tree == error_mark_node
3779                 || right_length == error_mark_node)
3780               return error_mark_node;
3781
3782             if ((ffebld_size_known (left) == 1)
3783                 && (ffebld_size_known (right) == 1))
3784               {
3785                 left_tree
3786                   = ffecom_1 (INDIRECT_REF,
3787                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3788                               left_tree);
3789                 right_tree
3790                   = ffecom_1 (INDIRECT_REF,
3791                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3792                               right_tree);
3793
3794                 item
3795                   = ffecom_2 (code, integer_type_node,
3796                               ffecom_2 (ARRAY_REF,
3797                       TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (left_tree))),
3798                                         left_tree,
3799                                         integer_one_node),
3800                               ffecom_2 (ARRAY_REF,
3801                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (right_tree))),
3802                                         right_tree,
3803                                         integer_one_node));
3804               }
3805             else
3806               {
3807                 item = build_tree_list (NULL_TREE, left_tree);
3808                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, right_tree);
3809                 TREE_CHAIN (TREE_CHAIN (item)) = build_tree_list (NULL_TREE,
3810                                                                left_length);
3811                 TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
3812                   = build_tree_list (NULL_TREE, right_length);
3813                 item = ffecom_call_gfrt (FFECOM_gfrtCMP, item, NULL_TREE);
3814                 item = ffecom_2 (code, integer_type_node,
3815                                  item,
3816                                  convert (TREE_TYPE (item),
3817                                           integer_zero_node));
3818               }
3819             item = convert (tree_type, item);
3820           }
3821
3822           return item;
3823
3824         default:
3825           assert ("relational bad basictype" == NULL);
3826           /* Fall through. */
3827         case FFEINFO_basictypeANY:
3828           return error_mark_node;
3829         }
3830       break;
3831
3832     case FFEBLD_opPERCENT_LOC:
3833       item = ffecom_arg_ptr_to_expr (ffebld_left (expr), &list);
3834       return convert (tree_type, item);
3835
3836     case FFEBLD_opITEM:
3837     case FFEBLD_opSTAR:
3838     case FFEBLD_opBOUNDS:
3839     case FFEBLD_opREPEAT:
3840     case FFEBLD_opLABTER:
3841     case FFEBLD_opLABTOK:
3842     case FFEBLD_opIMPDO:
3843     case FFEBLD_opCONCATENATE:
3844     case FFEBLD_opSUBSTR:
3845     default:
3846       assert ("bad op" == NULL);
3847       /* Fall through. */
3848     case FFEBLD_opANY:
3849       return error_mark_node;
3850     }
3851
3852 #if 1
3853   assert ("didn't think anything got here anymore!!" == NULL);
3854 #else
3855   switch (ffebld_arity (expr))
3856     {
3857     case 2:
3858       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3859       TREE_OPERAND (item, 1) = ffecom_expr (ffebld_right (expr));
3860       if (TREE_OPERAND (item, 0) == error_mark_node
3861           || TREE_OPERAND (item, 1) == error_mark_node)
3862         return error_mark_node;
3863       break;
3864
3865     case 1:
3866       TREE_OPERAND (item, 0) = ffecom_expr (ffebld_left (expr));
3867       if (TREE_OPERAND (item, 0) == error_mark_node)
3868         return error_mark_node;
3869       break;
3870
3871     default:
3872       break;
3873     }
3874
3875   return fold (item);
3876 #endif
3877 }
3878
3879 #endif
3880 /* Returns the tree that does the intrinsic invocation.
3881
3882    Note: this function applies only to intrinsics returning
3883    CHARACTER*1 or non-CHARACTER results, and to intrinsic
3884    subroutines.  */
3885
3886 #if FFECOM_targetCURRENT == FFECOM_targetGCC
3887 static tree
3888 ffecom_expr_intrinsic_ (ffebld expr, tree dest_tree,
3889                         ffebld dest, bool *dest_used)
3890 {
3891   tree expr_tree;
3892   tree saved_expr1;             /* For those who need it. */
3893   tree saved_expr2;             /* For those who need it. */
3894   ffeinfoBasictype bt;
3895   ffeinfoKindtype kt;
3896   tree tree_type;
3897   tree arg1_type;
3898   tree real_type;               /* REAL type corresponding to COMPLEX. */
3899   tree tempvar;
3900   ffebld list = ffebld_right (expr);    /* List of (some) args. */
3901   ffebld arg1;                  /* For handy reference. */
3902   ffebld arg2;
3903   ffebld arg3;
3904   ffeintrinImp codegen_imp;
3905   ffecomGfrt gfrt;
3906
3907   assert (ffebld_op (ffebld_left (expr)) == FFEBLD_opSYMTER);
3908
3909   if (dest_used != NULL)
3910     *dest_used = FALSE;
3911
3912   bt = ffeinfo_basictype (ffebld_info (expr));
3913   kt = ffeinfo_kindtype (ffebld_info (expr));
3914   tree_type = ffecom_tree_type[bt][kt];
3915
3916   if (list != NULL)
3917     {
3918       arg1 = ffebld_head (list);
3919       if (arg1 != NULL && ffebld_op (arg1) == FFEBLD_opANY)
3920         return error_mark_node;
3921       if ((list = ffebld_trail (list)) != NULL)
3922         {
3923           arg2 = ffebld_head (list);
3924           if (arg2 != NULL && ffebld_op (arg2) == FFEBLD_opANY)
3925             return error_mark_node;
3926           if ((list = ffebld_trail (list)) != NULL)
3927             {
3928               arg3 = ffebld_head (list);
3929               if (arg3 != NULL && ffebld_op (arg3) == FFEBLD_opANY)
3930                 return error_mark_node;
3931             }
3932           else
3933             arg3 = NULL;
3934         }
3935       else
3936         arg2 = arg3 = NULL;
3937     }
3938   else
3939     arg1 = arg2 = arg3 = NULL;
3940
3941   /* <list> ends up at the opITEM of the 3rd arg, or NULL if there are < 3
3942      args.  This is used by the MAX/MIN expansions. */
3943
3944   if (arg1 != NULL)
3945     arg1_type = ffecom_tree_type
3946       [ffeinfo_basictype (ffebld_info (arg1))]
3947       [ffeinfo_kindtype (ffebld_info (arg1))];
3948   else
3949     arg1_type = NULL_TREE;      /* Really not needed, but might catch bugs
3950                                    here. */
3951
3952   /* There are several ways for each of the cases in the following switch
3953      statements to exit (from simplest to use to most complicated):
3954
3955      break;  (when expr_tree == NULL)
3956
3957      A standard call is made to the specific intrinsic just as if it had been
3958      passed in as a dummy procedure and called as any old procedure.  This
3959      method can produce slower code but in some cases it's the easiest way for
3960      now.  However, if a (presumably faster) direct call is available,
3961      that is used, so this is the easiest way in many more cases now.
3962
3963      gfrt = FFECOM_gfrtWHATEVER;
3964      break;
3965
3966      gfrt contains the gfrt index of a library function to call, passing the
3967      argument(s) by value rather than by reference.  Used when a more
3968      careful choice of library function is needed than that provided
3969      by the vanilla `break;'.
3970
3971      return expr_tree;
3972
3973      The expr_tree has been completely set up and is ready to be returned
3974      as is.  No further actions are taken.  Use this when the tree is not
3975      in the simple form for one of the arity_n labels.   */
3976
3977   /* For info on how the switch statement cases were written, see the files
3978      enclosed in comments below the switch statement. */
3979
3980   codegen_imp = ffebld_symter_implementation (ffebld_left (expr));
3981   gfrt = ffeintrin_gfrt_direct (codegen_imp);
3982   if (gfrt == FFECOM_gfrt)
3983     gfrt = ffeintrin_gfrt_indirect (codegen_imp);
3984
3985   switch (codegen_imp)
3986     {
3987     case FFEINTRIN_impABS:
3988     case FFEINTRIN_impCABS:
3989     case FFEINTRIN_impCDABS:
3990     case FFEINTRIN_impDABS:
3991     case FFEINTRIN_impIABS:
3992       if (ffeinfo_basictype (ffebld_info (arg1))
3993           == FFEINFO_basictypeCOMPLEX)
3994         {
3995           if (kt == FFEINFO_kindtypeREAL1)
3996             gfrt = FFECOM_gfrtCABS;
3997           else if (kt == FFEINFO_kindtypeREAL2)
3998             gfrt = FFECOM_gfrtCDABS;
3999           break;
4000         }
4001       return ffecom_1 (ABS_EXPR, tree_type,
4002                        convert (tree_type, ffecom_expr (arg1)));
4003
4004     case FFEINTRIN_impACOS:
4005     case FFEINTRIN_impDACOS:
4006       break;
4007
4008     case FFEINTRIN_impAIMAG:
4009     case FFEINTRIN_impDIMAG:
4010     case FFEINTRIN_impIMAGPART:
4011       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
4012         arg1_type = TREE_TYPE (arg1_type);
4013       else
4014         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
4015
4016       return
4017         convert (tree_type,
4018                  ffecom_1 (IMAGPART_EXPR, arg1_type,
4019                            ffecom_expr (arg1)));
4020
4021     case FFEINTRIN_impAINT:
4022     case FFEINTRIN_impDINT:
4023 #if 0
4024       /* ~~Someday implement FIX_TRUNC_EXPR yielding same type as arg.  */
4025       return ffecom_1 (FIX_TRUNC_EXPR, tree_type, ffecom_expr (arg1));
4026 #else /* in the meantime, must use floor to avoid range problems with ints */
4027       /* r__1 = r1 >= 0 ? floor(r1) : -floor(-r1); */
4028       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4029       return
4030         convert (tree_type,
4031                  ffecom_3 (COND_EXPR, double_type_node,
4032                            ffecom_truth_value
4033                            (ffecom_2 (GE_EXPR, integer_type_node,
4034                                       saved_expr1,
4035                                       convert (arg1_type,
4036                                                ffecom_float_zero_))),
4037                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4038                                              build_tree_list (NULL_TREE,
4039                                                   convert (double_type_node,
4040                                                            saved_expr1)),
4041                                              NULL_TREE),
4042                            ffecom_1 (NEGATE_EXPR, double_type_node,
4043                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4044                                                  build_tree_list (NULL_TREE,
4045                                                   convert (double_type_node,
4046                                                       ffecom_1 (NEGATE_EXPR,
4047                                                                 arg1_type,
4048                                                                saved_expr1))),
4049                                                        NULL_TREE)
4050                                      ))
4051                  );
4052 #endif
4053
4054     case FFEINTRIN_impANINT:
4055     case FFEINTRIN_impDNINT:
4056 #if 0                           /* This way of doing it won't handle real
4057                                    numbers of large magnitudes. */
4058       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4059       expr_tree = convert (tree_type,
4060                            convert (integer_type_node,
4061                                     ffecom_3 (COND_EXPR, tree_type,
4062                                               ffecom_truth_value
4063                                               (ffecom_2 (GE_EXPR,
4064                                                          integer_type_node,
4065                                                          saved_expr1,
4066                                                        ffecom_float_zero_)),
4067                                               ffecom_2 (PLUS_EXPR,
4068                                                         tree_type,
4069                                                         saved_expr1,
4070                                                         ffecom_float_half_),
4071                                               ffecom_2 (MINUS_EXPR,
4072                                                         tree_type,
4073                                                         saved_expr1,
4074                                                      ffecom_float_half_))));
4075       return expr_tree;
4076 #else /* So we instead call floor. */
4077       /* r__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1) */
4078       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4079       return
4080         convert (tree_type,
4081                  ffecom_3 (COND_EXPR, double_type_node,
4082                            ffecom_truth_value
4083                            (ffecom_2 (GE_EXPR, integer_type_node,
4084                                       saved_expr1,
4085                                       convert (arg1_type,
4086                                                ffecom_float_zero_))),
4087                            ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4088                                              build_tree_list (NULL_TREE,
4089                                                   convert (double_type_node,
4090                                                            ffecom_2 (PLUS_EXPR,
4091                                                                      arg1_type,
4092                                                                      saved_expr1,
4093                                                                      convert (arg1_type,
4094                                                                               ffecom_float_half_)))),
4095                                              NULL_TREE),
4096                            ffecom_1 (NEGATE_EXPR, double_type_node,
4097                                      ffecom_call_gfrt (FFECOM_gfrtL_FLOOR,
4098                                                        build_tree_list (NULL_TREE,
4099                                                                         convert (double_type_node,
4100                                                                                  ffecom_2 (MINUS_EXPR,
4101                                                                                            arg1_type,
4102                                                                                            convert (arg1_type,
4103                                                                                                     ffecom_float_half_),
4104                                                                                            saved_expr1))),
4105                                                        NULL_TREE))
4106                            )
4107                  );
4108 #endif
4109
4110     case FFEINTRIN_impASIN:
4111     case FFEINTRIN_impDASIN:
4112     case FFEINTRIN_impATAN:
4113     case FFEINTRIN_impDATAN:
4114     case FFEINTRIN_impATAN2:
4115     case FFEINTRIN_impDATAN2:
4116       break;
4117
4118     case FFEINTRIN_impCHAR:
4119     case FFEINTRIN_impACHAR:
4120 #ifdef HOHO
4121       tempvar = ffecom_make_tempvar (char_type_node, 1, -1);
4122 #else
4123       tempvar = ffebld_nonter_hook (expr);
4124       assert (tempvar);
4125 #endif
4126       {
4127         tree tmv = TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (tempvar)));
4128
4129         expr_tree = ffecom_modify (tmv,
4130                                    ffecom_2 (ARRAY_REF, tmv, tempvar,
4131                                              integer_one_node),
4132                                    convert (tmv, ffecom_expr (arg1)));
4133       }
4134       expr_tree = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (tempvar),
4135                             expr_tree,
4136                             tempvar);
4137       expr_tree = ffecom_1 (ADDR_EXPR,
4138                             build_pointer_type (TREE_TYPE (expr_tree)),
4139                             expr_tree);
4140       return expr_tree;
4141
4142     case FFEINTRIN_impCMPLX:
4143     case FFEINTRIN_impDCMPLX:
4144       if (arg2 == NULL)
4145         return
4146           convert (tree_type, ffecom_expr (arg1));
4147
4148       real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4149       return
4150         ffecom_2 (COMPLEX_EXPR, tree_type,
4151                   convert (real_type, ffecom_expr (arg1)),
4152                   convert (real_type,
4153                            ffecom_expr (arg2)));
4154
4155     case FFEINTRIN_impCOMPLEX:
4156       return
4157         ffecom_2 (COMPLEX_EXPR, tree_type,
4158                   ffecom_expr (arg1),
4159                   ffecom_expr (arg2));
4160
4161     case FFEINTRIN_impCONJG:
4162     case FFEINTRIN_impDCONJG:
4163       {
4164         tree arg1_tree;
4165
4166         real_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
4167         arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4168         return
4169           ffecom_2 (COMPLEX_EXPR, tree_type,
4170                     ffecom_1 (REALPART_EXPR, real_type, arg1_tree),
4171                     ffecom_1 (NEGATE_EXPR, real_type,
4172                               ffecom_1 (IMAGPART_EXPR, real_type, arg1_tree)));
4173       }
4174
4175     case FFEINTRIN_impCOS:
4176     case FFEINTRIN_impCCOS:
4177     case FFEINTRIN_impCDCOS:
4178     case FFEINTRIN_impDCOS:
4179       if (bt == FFEINFO_basictypeCOMPLEX)
4180         {
4181           if (kt == FFEINFO_kindtypeREAL1)
4182             gfrt = FFECOM_gfrtCCOS;     /* Overlapping result okay. */
4183           else if (kt == FFEINFO_kindtypeREAL2)
4184             gfrt = FFECOM_gfrtCDCOS;    /* Overlapping result okay. */
4185         }
4186       break;
4187
4188     case FFEINTRIN_impCOSH:
4189     case FFEINTRIN_impDCOSH:
4190       break;
4191
4192     case FFEINTRIN_impDBLE:
4193     case FFEINTRIN_impDFLOAT:
4194     case FFEINTRIN_impDREAL:
4195     case FFEINTRIN_impFLOAT:
4196     case FFEINTRIN_impIDINT:
4197     case FFEINTRIN_impIFIX:
4198     case FFEINTRIN_impINT2:
4199     case FFEINTRIN_impINT8:
4200     case FFEINTRIN_impINT:
4201     case FFEINTRIN_impLONG:
4202     case FFEINTRIN_impREAL:
4203     case FFEINTRIN_impSHORT:
4204     case FFEINTRIN_impSNGL:
4205       return convert (tree_type, ffecom_expr (arg1));
4206
4207     case FFEINTRIN_impDIM:
4208     case FFEINTRIN_impDDIM:
4209     case FFEINTRIN_impIDIM:
4210       saved_expr1 = ffecom_save_tree (convert (tree_type,
4211                                                ffecom_expr (arg1)));
4212       saved_expr2 = ffecom_save_tree (convert (tree_type,
4213                                                ffecom_expr (arg2)));
4214       return
4215         ffecom_3 (COND_EXPR, tree_type,
4216                   ffecom_truth_value
4217                   (ffecom_2 (GT_EXPR, integer_type_node,
4218                              saved_expr1,
4219                              saved_expr2)),
4220                   ffecom_2 (MINUS_EXPR, tree_type,
4221                             saved_expr1,
4222                             saved_expr2),
4223                   convert (tree_type, ffecom_float_zero_));
4224
4225     case FFEINTRIN_impDPROD:
4226       return
4227         ffecom_2 (MULT_EXPR, tree_type,
4228                   convert (tree_type, ffecom_expr (arg1)),
4229                   convert (tree_type, ffecom_expr (arg2)));
4230
4231     case FFEINTRIN_impEXP:
4232     case FFEINTRIN_impCDEXP:
4233     case FFEINTRIN_impCEXP:
4234     case FFEINTRIN_impDEXP:
4235       if (bt == FFEINFO_basictypeCOMPLEX)
4236         {
4237           if (kt == FFEINFO_kindtypeREAL1)
4238             gfrt = FFECOM_gfrtCEXP;     /* Overlapping result okay. */
4239           else if (kt == FFEINFO_kindtypeREAL2)
4240             gfrt = FFECOM_gfrtCDEXP;    /* Overlapping result okay. */
4241         }
4242       break;
4243
4244     case FFEINTRIN_impICHAR:
4245     case FFEINTRIN_impIACHAR:
4246 #if 0                           /* The simple approach. */
4247       ffecom_char_args_ (&expr_tree, &saved_expr1 /* Ignored */ , arg1);
4248       expr_tree
4249         = ffecom_1 (INDIRECT_REF,
4250                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4251                     expr_tree);
4252       expr_tree
4253         = ffecom_2 (ARRAY_REF,
4254                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
4255                     expr_tree,
4256                     integer_one_node);
4257       return convert (tree_type, expr_tree);
4258 #else /* The more interesting (and more optimal) approach. */
4259       expr_tree = ffecom_intrinsic_ichar_ (tree_type, arg1, &saved_expr1);
4260       expr_tree = ffecom_3 (COND_EXPR, tree_type,
4261                             saved_expr1,
4262                             expr_tree,
4263                             convert (tree_type, integer_zero_node));
4264       return expr_tree;
4265 #endif
4266
4267     case FFEINTRIN_impINDEX:
4268       break;
4269
4270     case FFEINTRIN_impLEN:
4271 #if 0
4272       break;                                    /* The simple approach. */
4273 #else
4274       return ffecom_intrinsic_len_ (arg1);      /* The more optimal approach. */
4275 #endif
4276
4277     case FFEINTRIN_impLGE:
4278     case FFEINTRIN_impLGT:
4279     case FFEINTRIN_impLLE:
4280     case FFEINTRIN_impLLT:
4281       break;
4282
4283     case FFEINTRIN_impLOG:
4284     case FFEINTRIN_impALOG:
4285     case FFEINTRIN_impCDLOG:
4286     case FFEINTRIN_impCLOG:
4287     case FFEINTRIN_impDLOG:
4288       if (bt == FFEINFO_basictypeCOMPLEX)
4289         {
4290           if (kt == FFEINFO_kindtypeREAL1)
4291             gfrt = FFECOM_gfrtCLOG;     /* Overlapping result okay. */
4292           else if (kt == FFEINFO_kindtypeREAL2)
4293             gfrt = FFECOM_gfrtCDLOG;    /* Overlapping result okay. */
4294         }
4295       break;
4296
4297     case FFEINTRIN_impLOG10:
4298     case FFEINTRIN_impALOG10:
4299     case FFEINTRIN_impDLOG10:
4300       if (gfrt != FFECOM_gfrt)
4301         break;  /* Already picked one, stick with it. */
4302
4303       if (kt == FFEINFO_kindtypeREAL1)
4304         /* We used to call FFECOM_gfrtALOG10 here.  */
4305         gfrt = FFECOM_gfrtL_LOG10;
4306       else if (kt == FFEINFO_kindtypeREAL2)
4307         /* We used to call FFECOM_gfrtDLOG10 here.  */
4308         gfrt = FFECOM_gfrtL_LOG10;
4309       break;
4310
4311     case FFEINTRIN_impMAX:
4312     case FFEINTRIN_impAMAX0:
4313     case FFEINTRIN_impAMAX1:
4314     case FFEINTRIN_impDMAX1:
4315     case FFEINTRIN_impMAX0:
4316     case FFEINTRIN_impMAX1:
4317       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4318         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4319       else
4320         arg1_type = tree_type;
4321       expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4322                             convert (arg1_type, ffecom_expr (arg1)),
4323                             convert (arg1_type, ffecom_expr (arg2)));
4324       for (; list != NULL; list = ffebld_trail (list))
4325         {
4326           if ((ffebld_head (list) == NULL)
4327               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4328             continue;
4329           expr_tree = ffecom_2 (MAX_EXPR, arg1_type,
4330                                 expr_tree,
4331                                 convert (arg1_type,
4332                                          ffecom_expr (ffebld_head (list))));
4333         }
4334       return convert (tree_type, expr_tree);
4335
4336     case FFEINTRIN_impMIN:
4337     case FFEINTRIN_impAMIN0:
4338     case FFEINTRIN_impAMIN1:
4339     case FFEINTRIN_impDMIN1:
4340     case FFEINTRIN_impMIN0:
4341     case FFEINTRIN_impMIN1:
4342       if (bt != ffeinfo_basictype (ffebld_info (arg1)))
4343         arg1_type = ffecom_widest_expr_type_ (ffebld_right (expr));
4344       else
4345         arg1_type = tree_type;
4346       expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4347                             convert (arg1_type, ffecom_expr (arg1)),
4348                             convert (arg1_type, ffecom_expr (arg2)));
4349       for (; list != NULL; list = ffebld_trail (list))
4350         {
4351           if ((ffebld_head (list) == NULL)
4352               || (ffebld_op (ffebld_head (list)) == FFEBLD_opANY))
4353             continue;
4354           expr_tree = ffecom_2 (MIN_EXPR, arg1_type,
4355                                 expr_tree,
4356                                 convert (arg1_type,
4357                                          ffecom_expr (ffebld_head (list))));
4358         }
4359       return convert (tree_type, expr_tree);
4360
4361     case FFEINTRIN_impMOD:
4362     case FFEINTRIN_impAMOD:
4363     case FFEINTRIN_impDMOD:
4364       if (bt != FFEINFO_basictypeREAL)
4365         return ffecom_2 (TRUNC_MOD_EXPR, tree_type,
4366                          convert (tree_type, ffecom_expr (arg1)),
4367                          convert (tree_type, ffecom_expr (arg2)));
4368
4369       if (kt == FFEINFO_kindtypeREAL1)
4370         /* We used to call FFECOM_gfrtAMOD here.  */
4371         gfrt = FFECOM_gfrtL_FMOD;
4372       else if (kt == FFEINFO_kindtypeREAL2)
4373         /* We used to call FFECOM_gfrtDMOD here.  */
4374         gfrt = FFECOM_gfrtL_FMOD;
4375       break;
4376
4377     case FFEINTRIN_impNINT:
4378     case FFEINTRIN_impIDNINT:
4379 #if 0
4380       /* ~~Ideally FIX_ROUND_EXPR would be implemented, but it ain't yet.  */
4381       return ffecom_1 (FIX_ROUND_EXPR, tree_type, ffecom_expr (arg1));
4382 #else
4383       /* i__1 = r1 >= 0 ? floor(r1 + .5) : -floor(.5 - r1); */
4384       saved_expr1 = ffecom_save_tree (ffecom_expr (arg1));
4385       return
4386         convert (ffecom_integer_type_node,
4387                  ffecom_3 (COND_EXPR, arg1_type,
4388                            ffecom_truth_value
4389                            (ffecom_2 (GE_EXPR, integer_type_node,
4390                                       saved_expr1,
4391                                       convert (arg1_type,
4392                                                ffecom_float_zero_))),
4393                            ffecom_2 (PLUS_EXPR, arg1_type,
4394                                      saved_expr1,
4395                                      convert (arg1_type,
4396                                               ffecom_float_half_)),
4397                            ffecom_2 (MINUS_EXPR, arg1_type,
4398                                      saved_expr1,
4399                                      convert (arg1_type,
4400                                               ffecom_float_half_))));
4401 #endif
4402
4403     case FFEINTRIN_impSIGN:
4404     case FFEINTRIN_impDSIGN:
4405     case FFEINTRIN_impISIGN:
4406       {
4407         tree arg2_tree = ffecom_expr (arg2);
4408
4409         saved_expr1
4410           = ffecom_save_tree
4411           (ffecom_1 (ABS_EXPR, tree_type,
4412                      convert (tree_type,
4413                               ffecom_expr (arg1))));
4414         expr_tree
4415           = ffecom_3 (COND_EXPR, tree_type,
4416                       ffecom_truth_value
4417                       (ffecom_2 (GE_EXPR, integer_type_node,
4418                                  arg2_tree,
4419                                  convert (TREE_TYPE (arg2_tree),
4420                                           integer_zero_node))),
4421                       saved_expr1,
4422                       ffecom_1 (NEGATE_EXPR, tree_type, saved_expr1));
4423         /* Make sure SAVE_EXPRs get referenced early enough. */
4424         expr_tree
4425           = ffecom_2 (COMPOUND_EXPR, tree_type,
4426                       convert (void_type_node, saved_expr1),
4427                       expr_tree);
4428       }
4429       return expr_tree;
4430
4431     case FFEINTRIN_impSIN:
4432     case FFEINTRIN_impCDSIN:
4433     case FFEINTRIN_impCSIN:
4434     case FFEINTRIN_impDSIN:
4435       if (bt == FFEINFO_basictypeCOMPLEX)
4436         {
4437           if (kt == FFEINFO_kindtypeREAL1)
4438             gfrt = FFECOM_gfrtCSIN;     /* Overlapping result okay. */
4439           else if (kt == FFEINFO_kindtypeREAL2)
4440             gfrt = FFECOM_gfrtCDSIN;    /* Overlapping result okay. */
4441         }
4442       break;
4443
4444     case FFEINTRIN_impSINH:
4445     case FFEINTRIN_impDSINH:
4446       break;
4447
4448     case FFEINTRIN_impSQRT:
4449     case FFEINTRIN_impCDSQRT:
4450     case FFEINTRIN_impCSQRT:
4451     case FFEINTRIN_impDSQRT:
4452       if (bt == FFEINFO_basictypeCOMPLEX)
4453         {
4454           if (kt == FFEINFO_kindtypeREAL1)
4455             gfrt = FFECOM_gfrtCSQRT;    /* Overlapping result okay. */
4456           else if (kt == FFEINFO_kindtypeREAL2)
4457             gfrt = FFECOM_gfrtCDSQRT;   /* Overlapping result okay. */
4458         }
4459       break;
4460
4461     case FFEINTRIN_impTAN:
4462     case FFEINTRIN_impDTAN:
4463     case FFEINTRIN_impTANH:
4464     case FFEINTRIN_impDTANH:
4465       break;
4466
4467     case FFEINTRIN_impREALPART:
4468       if (TREE_CODE (arg1_type) == COMPLEX_TYPE)
4469         arg1_type = TREE_TYPE (arg1_type);
4470       else
4471         arg1_type = TREE_TYPE (TYPE_FIELDS (arg1_type));
4472
4473       return
4474         convert (tree_type,
4475                  ffecom_1 (REALPART_EXPR, arg1_type,
4476                            ffecom_expr (arg1)));
4477
4478     case FFEINTRIN_impIAND:
4479     case FFEINTRIN_impAND:
4480       return ffecom_2 (BIT_AND_EXPR, tree_type,
4481                        convert (tree_type,
4482                                 ffecom_expr (arg1)),
4483                        convert (tree_type,
4484                                 ffecom_expr (arg2)));
4485
4486     case FFEINTRIN_impIOR:
4487     case FFEINTRIN_impOR:
4488       return ffecom_2 (BIT_IOR_EXPR, tree_type,
4489                        convert (tree_type,
4490                                 ffecom_expr (arg1)),
4491                        convert (tree_type,
4492                                 ffecom_expr (arg2)));
4493
4494     case FFEINTRIN_impIEOR:
4495     case FFEINTRIN_impXOR:
4496       return ffecom_2 (BIT_XOR_EXPR, tree_type,
4497                        convert (tree_type,
4498                                 ffecom_expr (arg1)),
4499                        convert (tree_type,
4500                                 ffecom_expr (arg2)));
4501
4502     case FFEINTRIN_impLSHIFT:
4503       return ffecom_2 (LSHIFT_EXPR, tree_type,
4504                        ffecom_expr (arg1),
4505                        convert (integer_type_node,
4506                                 ffecom_expr (arg2)));
4507
4508     case FFEINTRIN_impRSHIFT:
4509       return ffecom_2 (RSHIFT_EXPR, tree_type,
4510                        ffecom_expr (arg1),
4511                        convert (integer_type_node,
4512                                 ffecom_expr (arg2)));
4513
4514     case FFEINTRIN_impNOT:
4515       return ffecom_1 (BIT_NOT_EXPR, tree_type, ffecom_expr (arg1));
4516
4517     case FFEINTRIN_impBIT_SIZE:
4518       return convert (tree_type, TYPE_SIZE (arg1_type));
4519
4520     case FFEINTRIN_impBTEST:
4521       {
4522         ffetargetLogical1 true;
4523         ffetargetLogical1 false;
4524         tree true_tree;
4525         tree false_tree;
4526
4527         ffetarget_logical1 (&true, TRUE);
4528         ffetarget_logical1 (&false, FALSE);
4529         if (true == 1)
4530           true_tree = convert (tree_type, integer_one_node);
4531         else
4532           true_tree = convert (tree_type, build_int_2 (true, 0));
4533         if (false == 0)
4534           false_tree = convert (tree_type, integer_zero_node);
4535         else
4536           false_tree = convert (tree_type, build_int_2 (false, 0));
4537
4538         return
4539           ffecom_3 (COND_EXPR, tree_type,
4540                     ffecom_truth_value
4541                     (ffecom_2 (EQ_EXPR, integer_type_node,
4542                                ffecom_2 (BIT_AND_EXPR, arg1_type,
4543                                          ffecom_expr (arg1),
4544                                          ffecom_2 (LSHIFT_EXPR, arg1_type,
4545                                                    convert (arg1_type,
4546                                                           integer_one_node),
4547                                                    convert (integer_type_node,
4548                                                             ffecom_expr (arg2)))),
4549                                convert (arg1_type,
4550                                         integer_zero_node))),
4551                     false_tree,
4552                     true_tree);
4553       }
4554
4555     case FFEINTRIN_impIBCLR:
4556       return
4557         ffecom_2 (BIT_AND_EXPR, tree_type,
4558                   ffecom_expr (arg1),
4559                   ffecom_1 (BIT_NOT_EXPR, tree_type,
4560                             ffecom_2 (LSHIFT_EXPR, tree_type,
4561                                       convert (tree_type,
4562                                                integer_one_node),
4563                                       convert (integer_type_node,
4564                                                ffecom_expr (arg2)))));
4565
4566     case FFEINTRIN_impIBITS:
4567       {
4568         tree arg3_tree = ffecom_save_tree (convert (integer_type_node,
4569                                                     ffecom_expr (arg3)));
4570         tree uns_type
4571         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4572
4573         expr_tree
4574           = ffecom_2 (BIT_AND_EXPR, tree_type,
4575                       ffecom_2 (RSHIFT_EXPR, tree_type,
4576                                 ffecom_expr (arg1),
4577                                 convert (integer_type_node,
4578                                          ffecom_expr (arg2))),
4579                       convert (tree_type,
4580                                ffecom_2 (RSHIFT_EXPR, uns_type,
4581                                          ffecom_1 (BIT_NOT_EXPR,
4582                                                    uns_type,
4583                                                    convert (uns_type,
4584                                                         integer_zero_node)),
4585                                          ffecom_2 (MINUS_EXPR,
4586                                                    integer_type_node,
4587                                                    TYPE_SIZE (uns_type),
4588                                                    arg3_tree))));
4589 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4590         expr_tree
4591           = ffecom_3 (COND_EXPR, tree_type,
4592                       ffecom_truth_value
4593                       (ffecom_2 (NE_EXPR, integer_type_node,
4594                                  arg3_tree,
4595                                  integer_zero_node)),
4596                       expr_tree,
4597                       convert (tree_type, integer_zero_node));
4598 #endif
4599       }
4600       return expr_tree;
4601
4602     case FFEINTRIN_impIBSET:
4603       return
4604         ffecom_2 (BIT_IOR_EXPR, tree_type,
4605                   ffecom_expr (arg1),
4606                   ffecom_2 (LSHIFT_EXPR, tree_type,
4607                             convert (tree_type, integer_one_node),
4608                             convert (integer_type_node,
4609                                      ffecom_expr (arg2))));
4610
4611     case FFEINTRIN_impISHFT:
4612       {
4613         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4614         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4615                                                     ffecom_expr (arg2)));
4616         tree uns_type
4617         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4618
4619         expr_tree
4620           = ffecom_3 (COND_EXPR, tree_type,
4621                       ffecom_truth_value
4622                       (ffecom_2 (GE_EXPR, integer_type_node,
4623                                  arg2_tree,
4624                                  integer_zero_node)),
4625                       ffecom_2 (LSHIFT_EXPR, tree_type,
4626                                 arg1_tree,
4627                                 arg2_tree),
4628                       convert (tree_type,
4629                                ffecom_2 (RSHIFT_EXPR, uns_type,
4630                                          convert (uns_type, arg1_tree),
4631                                          ffecom_1 (NEGATE_EXPR,
4632                                                    integer_type_node,
4633                                                    arg2_tree))));
4634 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4635         expr_tree
4636           = ffecom_3 (COND_EXPR, tree_type,
4637                       ffecom_truth_value
4638                       (ffecom_2 (NE_EXPR, integer_type_node,
4639                                  arg2_tree,
4640                                  TYPE_SIZE (uns_type))),
4641                       expr_tree,
4642                       convert (tree_type, integer_zero_node));
4643 #endif
4644         /* Make sure SAVE_EXPRs get referenced early enough. */
4645         expr_tree
4646           = ffecom_2 (COMPOUND_EXPR, tree_type,
4647                       convert (void_type_node, arg1_tree),
4648                       ffecom_2 (COMPOUND_EXPR, tree_type,
4649                                 convert (void_type_node, arg2_tree),
4650                                 expr_tree));
4651       }
4652       return expr_tree;
4653
4654     case FFEINTRIN_impISHFTC:
4655       {
4656         tree arg1_tree = ffecom_save_tree (ffecom_expr (arg1));
4657         tree arg2_tree = ffecom_save_tree (convert (integer_type_node,
4658                                                     ffecom_expr (arg2)));
4659         tree arg3_tree = (arg3 == NULL) ? TYPE_SIZE (tree_type)
4660         : ffecom_save_tree (convert (integer_type_node, ffecom_expr (arg3)));
4661         tree shift_neg;
4662         tree shift_pos;
4663         tree mask_arg1;
4664         tree masked_arg1;
4665         tree uns_type
4666         = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
4667
4668         mask_arg1
4669           = ffecom_2 (LSHIFT_EXPR, tree_type,
4670                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4671                                 convert (tree_type, integer_zero_node)),
4672                       arg3_tree);
4673 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4674         mask_arg1
4675           = ffecom_3 (COND_EXPR, tree_type,
4676                       ffecom_truth_value
4677                       (ffecom_2 (NE_EXPR, integer_type_node,
4678                                  arg3_tree,
4679                                  TYPE_SIZE (uns_type))),
4680                       mask_arg1,
4681                       convert (tree_type, integer_zero_node));
4682 #endif
4683         mask_arg1 = ffecom_save_tree (mask_arg1);
4684         masked_arg1
4685           = ffecom_2 (BIT_AND_EXPR, tree_type,
4686                       arg1_tree,
4687                       ffecom_1 (BIT_NOT_EXPR, tree_type,
4688                                 mask_arg1));
4689         masked_arg1 = ffecom_save_tree (masked_arg1);
4690         shift_neg
4691           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4692                       convert (tree_type,
4693                                ffecom_2 (RSHIFT_EXPR, uns_type,
4694                                          convert (uns_type, masked_arg1),
4695                                          ffecom_1 (NEGATE_EXPR,
4696                                                    integer_type_node,
4697                                                    arg2_tree))),
4698                       ffecom_2 (LSHIFT_EXPR, tree_type,
4699                                 arg1_tree,
4700                                 ffecom_2 (PLUS_EXPR, integer_type_node,
4701                                           arg2_tree,
4702                                           arg3_tree)));
4703         shift_pos
4704           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4705                       ffecom_2 (LSHIFT_EXPR, tree_type,
4706                                 arg1_tree,
4707                                 arg2_tree),
4708                       convert (tree_type,
4709                                ffecom_2 (RSHIFT_EXPR, uns_type,
4710                                          convert (uns_type, masked_arg1),
4711                                          ffecom_2 (MINUS_EXPR,
4712                                                    integer_type_node,
4713                                                    arg3_tree,
4714                                                    arg2_tree))));
4715         expr_tree
4716           = ffecom_3 (COND_EXPR, tree_type,
4717                       ffecom_truth_value
4718                       (ffecom_2 (LT_EXPR, integer_type_node,
4719                                  arg2_tree,
4720                                  integer_zero_node)),
4721                       shift_neg,
4722                       shift_pos);
4723         expr_tree
4724           = ffecom_2 (BIT_IOR_EXPR, tree_type,
4725                       ffecom_2 (BIT_AND_EXPR, tree_type,
4726                                 mask_arg1,
4727                                 arg1_tree),
4728                       ffecom_2 (BIT_AND_EXPR, tree_type,
4729                                 ffecom_1 (BIT_NOT_EXPR, tree_type,
4730                                           mask_arg1),
4731                                 expr_tree));
4732         expr_tree
4733           = ffecom_3 (COND_EXPR, tree_type,
4734                       ffecom_truth_value
4735                       (ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
4736                                  ffecom_2 (EQ_EXPR, integer_type_node,
4737                                            ffecom_1 (ABS_EXPR,
4738                                                      integer_type_node,
4739                                                      arg2_tree),
4740                                            arg3_tree),
4741                                  ffecom_2 (EQ_EXPR, integer_type_node,
4742                                            arg2_tree,
4743                                            integer_zero_node))),
4744                       arg1_tree,
4745                       expr_tree);
4746         /* Make sure SAVE_EXPRs get referenced early enough. */
4747         expr_tree
4748           = ffecom_2 (COMPOUND_EXPR, tree_type,
4749                       convert (void_type_node, arg1_tree),
4750                       ffecom_2 (COMPOUND_EXPR, tree_type,
4751                                 convert (void_type_node, arg2_tree),
4752                                 ffecom_2 (COMPOUND_EXPR, tree_type,
4753                                           convert (void_type_node,
4754                                                    mask_arg1),
4755                                           ffecom_2 (COMPOUND_EXPR, tree_type,
4756                                                     convert (void_type_node,
4757                                                              masked_arg1),
4758                                                     expr_tree))));
4759         expr_tree
4760           = ffecom_2 (COMPOUND_EXPR, tree_type,
4761                       convert (void_type_node,
4762                                arg3_tree),
4763                       expr_tree);
4764       }
4765       return expr_tree;
4766
4767     case FFEINTRIN_impLOC:
4768       {
4769         tree arg1_tree = ffecom_expr (arg1);
4770
4771         expr_tree
4772           = convert (tree_type,
4773                      ffecom_1 (ADDR_EXPR,
4774                                build_pointer_type (TREE_TYPE (arg1_tree)),
4775                                arg1_tree));
4776       }
4777       return expr_tree;
4778
4779     case FFEINTRIN_impMVBITS:
4780       {
4781         tree arg1_tree;
4782         tree arg2_tree;
4783         tree arg3_tree;
4784         ffebld arg4 = ffebld_head (ffebld_trail (list));
4785         tree arg4_tree;
4786         tree arg4_type;
4787         ffebld arg5 = ffebld_head (ffebld_trail (ffebld_trail (list)));
4788         tree arg5_tree;
4789         tree prep_arg1;
4790         tree prep_arg4;
4791         tree arg5_plus_arg3;
4792
4793         arg2_tree = convert (integer_type_node,
4794                              ffecom_expr (arg2));
4795         arg3_tree = ffecom_save_tree (convert (integer_type_node,
4796                                                ffecom_expr (arg3)));
4797         arg4_tree = ffecom_expr_rw (NULL_TREE, arg4);
4798         arg4_type = TREE_TYPE (arg4_tree);
4799
4800         arg1_tree = ffecom_save_tree (convert (arg4_type,
4801                                                ffecom_expr (arg1)));
4802
4803         arg5_tree = ffecom_save_tree (convert (integer_type_node,
4804                                                ffecom_expr (arg5)));
4805
4806         prep_arg1
4807           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4808                       ffecom_2 (BIT_AND_EXPR, arg4_type,
4809                                 ffecom_2 (RSHIFT_EXPR, arg4_type,
4810                                           arg1_tree,
4811                                           arg2_tree),
4812                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4813                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4814                                                     ffecom_1 (BIT_NOT_EXPR,
4815                                                               arg4_type,
4816                                                               convert
4817                                                               (arg4_type,
4818                                                         integer_zero_node)),
4819                                                     arg3_tree))),
4820                       arg5_tree);
4821         arg5_plus_arg3
4822           = ffecom_save_tree (ffecom_2 (PLUS_EXPR, arg4_type,
4823                                         arg5_tree,
4824                                         arg3_tree));
4825         prep_arg4
4826           = ffecom_2 (LSHIFT_EXPR, arg4_type,
4827                       ffecom_1 (BIT_NOT_EXPR, arg4_type,
4828                                 convert (arg4_type,
4829                                          integer_zero_node)),
4830                       arg5_plus_arg3);
4831 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4832         prep_arg4
4833           = ffecom_3 (COND_EXPR, arg4_type,
4834                       ffecom_truth_value
4835                       (ffecom_2 (NE_EXPR, integer_type_node,
4836                                  arg5_plus_arg3,
4837                                  convert (TREE_TYPE (arg5_plus_arg3),
4838                                           TYPE_SIZE (arg4_type)))),
4839                       prep_arg4,
4840                       convert (arg4_type, integer_zero_node));
4841 #endif
4842         prep_arg4
4843           = ffecom_2 (BIT_AND_EXPR, arg4_type,
4844                       arg4_tree,
4845                       ffecom_2 (BIT_IOR_EXPR, arg4_type,
4846                                 prep_arg4,
4847                                 ffecom_1 (BIT_NOT_EXPR, arg4_type,
4848                                           ffecom_2 (LSHIFT_EXPR, arg4_type,
4849                                                     ffecom_1 (BIT_NOT_EXPR,
4850                                                               arg4_type,
4851                                                               convert
4852                                                               (arg4_type,
4853                                                         integer_zero_node)),
4854                                                     arg5_tree))));
4855         prep_arg1
4856           = ffecom_2 (BIT_IOR_EXPR, arg4_type,
4857                       prep_arg1,
4858                       prep_arg4);
4859 #if !defined(TREE_SHIFT_FULLWIDTH) || !TREE_SHIFT_FULLWIDTH
4860         prep_arg1
4861           = ffecom_3 (COND_EXPR, arg4_type,
4862                       ffecom_truth_value
4863                       (ffecom_2 (NE_EXPR, integer_type_node,
4864                                  arg3_tree,
4865                                  convert (TREE_TYPE (arg3_tree),
4866                                           integer_zero_node))),
4867                       prep_arg1,
4868                       arg4_tree);
4869         prep_arg1
4870           = ffecom_3 (COND_EXPR, arg4_type,
4871                       ffecom_truth_value
4872                       (ffecom_2 (NE_EXPR, integer_type_node,
4873                                  arg3_tree,
4874                                  convert (TREE_TYPE (arg3_tree),
4875                                           TYPE_SIZE (arg4_type)))),
4876                       prep_arg1,
4877                       arg1_tree);
4878 #endif
4879         expr_tree
4880           = ffecom_2s (MODIFY_EXPR, void_type_node,
4881                        arg4_tree,
4882                        prep_arg1);
4883         /* Make sure SAVE_EXPRs get referenced early enough. */
4884         expr_tree
4885           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4886                       arg1_tree,
4887                       ffecom_2 (COMPOUND_EXPR, void_type_node,
4888                                 arg3_tree,
4889                                 ffecom_2 (COMPOUND_EXPR, void_type_node,
4890                                           arg5_tree,
4891                                           ffecom_2 (COMPOUND_EXPR, void_type_node,
4892                                                     arg5_plus_arg3,
4893                                                     expr_tree))));
4894         expr_tree
4895           = ffecom_2 (COMPOUND_EXPR, void_type_node,
4896                       arg4_tree,
4897                       expr_tree);
4898
4899       }
4900       return expr_tree;
4901
4902     case FFEINTRIN_impDERF:
4903     case FFEINTRIN_impERF:
4904     case FFEINTRIN_impDERFC:
4905     case FFEINTRIN_impERFC:
4906       break;
4907
4908     case FFEINTRIN_impIARGC:
4909       /* extern int xargc; i__1 = xargc - 1; */
4910       expr_tree = ffecom_2 (MINUS_EXPR, TREE_TYPE (ffecom_tree_xargc_),
4911                             ffecom_tree_xargc_,
4912                             convert (TREE_TYPE (ffecom_tree_xargc_),
4913                                      integer_one_node));
4914       return expr_tree;
4915
4916     case FFEINTRIN_impSIGNAL_func:
4917     case FFEINTRIN_impSIGNAL_subr:
4918       {
4919         tree arg1_tree;
4920         tree arg2_tree;
4921         tree arg3_tree;
4922
4923         arg1_tree = convert (ffecom_f2c_integer_type_node,
4924                              ffecom_expr (arg1));
4925         arg1_tree = ffecom_1 (ADDR_EXPR,
4926                               build_pointer_type (TREE_TYPE (arg1_tree)),
4927                               arg1_tree);
4928
4929         /* Pass procedure as a pointer to it, anything else by value.  */
4930         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4931           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4932         else
4933           arg2_tree = ffecom_ptr_to_expr (arg2);
4934         arg2_tree = convert (TREE_TYPE (null_pointer_node),
4935                              arg2_tree);
4936
4937         if (arg3 != NULL)
4938           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4939         else
4940           arg3_tree = NULL_TREE;
4941
4942         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4943         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4944         TREE_CHAIN (arg1_tree) = arg2_tree;
4945
4946         expr_tree
4947           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4948                           ffecom_gfrt_kindtype (gfrt),
4949                           FALSE,
4950                           ((codegen_imp == FFEINTRIN_impSIGNAL_subr) ?
4951                            NULL_TREE :
4952                            tree_type),
4953                           arg1_tree,
4954                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
4955                           ffebld_nonter_hook (expr));
4956
4957         if (arg3_tree != NULL_TREE)
4958           expr_tree
4959             = ffecom_modify (NULL_TREE, arg3_tree,
4960                              convert (TREE_TYPE (arg3_tree),
4961                                       expr_tree));
4962       }
4963       return expr_tree;
4964
4965     case FFEINTRIN_impALARM:
4966       {
4967         tree arg1_tree;
4968         tree arg2_tree;
4969         tree arg3_tree;
4970
4971         arg1_tree = convert (ffecom_f2c_integer_type_node,
4972                              ffecom_expr (arg1));
4973         arg1_tree = ffecom_1 (ADDR_EXPR,
4974                               build_pointer_type (TREE_TYPE (arg1_tree)),
4975                               arg1_tree);
4976
4977         /* Pass procedure as a pointer to it, anything else by value.  */
4978         if (ffeinfo_kind (ffebld_info (arg2)) == FFEINFO_kindENTITY)
4979           arg2_tree = convert (integer_type_node, ffecom_expr (arg2));
4980         else
4981           arg2_tree = ffecom_ptr_to_expr (arg2);
4982         arg2_tree = convert (TREE_TYPE (null_pointer_node),
4983                              arg2_tree);
4984
4985         if (arg3 != NULL)
4986           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
4987         else
4988           arg3_tree = NULL_TREE;
4989
4990         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
4991         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
4992         TREE_CHAIN (arg1_tree) = arg2_tree;
4993
4994         expr_tree
4995           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
4996                           ffecom_gfrt_kindtype (gfrt),
4997                           FALSE,
4998                           NULL_TREE,
4999                           arg1_tree,
5000                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5001                           ffebld_nonter_hook (expr));
5002
5003         if (arg3_tree != NULL_TREE)
5004           expr_tree
5005             = ffecom_modify (NULL_TREE, arg3_tree,
5006                              convert (TREE_TYPE (arg3_tree),
5007                                       expr_tree));
5008       }
5009       return expr_tree;
5010
5011     case FFEINTRIN_impCHDIR_subr:
5012     case FFEINTRIN_impFDATE_subr:
5013     case FFEINTRIN_impFGET_subr:
5014     case FFEINTRIN_impFPUT_subr:
5015     case FFEINTRIN_impGETCWD_subr:
5016     case FFEINTRIN_impHOSTNM_subr:
5017     case FFEINTRIN_impSYSTEM_subr:
5018     case FFEINTRIN_impUNLINK_subr:
5019       {
5020         tree arg1_len = integer_zero_node;
5021         tree arg1_tree;
5022         tree arg2_tree;
5023
5024         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5025
5026         if (arg2 != NULL)
5027           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
5028         else
5029           arg2_tree = NULL_TREE;
5030
5031         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5032         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5033         TREE_CHAIN (arg1_tree) = arg1_len;
5034
5035         expr_tree
5036           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5037                           ffecom_gfrt_kindtype (gfrt),
5038                           FALSE,
5039                           NULL_TREE,
5040                           arg1_tree,
5041                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5042                           ffebld_nonter_hook (expr));
5043
5044         if (arg2_tree != NULL_TREE)
5045           expr_tree
5046             = ffecom_modify (NULL_TREE, arg2_tree,
5047                              convert (TREE_TYPE (arg2_tree),
5048                                       expr_tree));
5049       }
5050       return expr_tree;
5051
5052     case FFEINTRIN_impEXIT:
5053       if (arg1 != NULL)
5054         break;
5055
5056       expr_tree = build_tree_list (NULL_TREE,
5057                                    ffecom_1 (ADDR_EXPR,
5058                                              build_pointer_type
5059                                              (ffecom_integer_type_node),
5060                                              integer_zero_node));
5061
5062       return
5063         ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5064                       ffecom_gfrt_kindtype (gfrt),
5065                       FALSE,
5066                       void_type_node,
5067                       expr_tree,
5068                       NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5069                       ffebld_nonter_hook (expr));
5070
5071     case FFEINTRIN_impFLUSH:
5072       if (arg1 == NULL)
5073         gfrt = FFECOM_gfrtFLUSH;
5074       else
5075         gfrt = FFECOM_gfrtFLUSH1;
5076       break;
5077
5078     case FFEINTRIN_impCHMOD_subr:
5079     case FFEINTRIN_impLINK_subr:
5080     case FFEINTRIN_impRENAME_subr:
5081     case FFEINTRIN_impSYMLNK_subr:
5082       {
5083         tree arg1_len = integer_zero_node;
5084         tree arg1_tree;
5085         tree arg2_len = integer_zero_node;
5086         tree arg2_tree;
5087         tree arg3_tree;
5088
5089         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5090         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
5091         if (arg3 != NULL)
5092           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5093         else
5094           arg3_tree = NULL_TREE;
5095
5096         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5097         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5098         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5099         arg2_len = build_tree_list (NULL_TREE, arg2_len);
5100         TREE_CHAIN (arg1_tree) = arg2_tree;
5101         TREE_CHAIN (arg2_tree) = arg1_len;
5102         TREE_CHAIN (arg1_len) = arg2_len;
5103         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5104                                   ffecom_gfrt_kindtype (gfrt),
5105                                   FALSE,
5106                                   NULL_TREE,
5107                                   arg1_tree,
5108                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5109                                   ffebld_nonter_hook (expr));
5110         if (arg3_tree != NULL_TREE)
5111           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5112                                      convert (TREE_TYPE (arg3_tree),
5113                                               expr_tree));
5114       }
5115       return expr_tree;
5116
5117     case FFEINTRIN_impLSTAT_subr:
5118     case FFEINTRIN_impSTAT_subr:
5119       {
5120         tree arg1_len = integer_zero_node;
5121         tree arg1_tree;
5122         tree arg2_tree;
5123         tree arg3_tree;
5124
5125         arg1_tree = ffecom_arg_ptr_to_expr (arg1, &arg1_len);
5126
5127         arg2_tree = ffecom_ptr_to_expr (arg2);
5128
5129         if (arg3 != NULL)
5130           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5131         else
5132           arg3_tree = NULL_TREE;
5133
5134         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5135         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5136         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5137         TREE_CHAIN (arg1_tree) = arg2_tree;
5138         TREE_CHAIN (arg2_tree) = arg1_len;
5139         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5140                                   ffecom_gfrt_kindtype (gfrt),
5141                                   FALSE,
5142                                   NULL_TREE,
5143                                   arg1_tree,
5144                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5145                                   ffebld_nonter_hook (expr));
5146         if (arg3_tree != NULL_TREE)
5147           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5148                                      convert (TREE_TYPE (arg3_tree),
5149                                               expr_tree));
5150       }
5151       return expr_tree;
5152
5153     case FFEINTRIN_impFGETC_subr:
5154     case FFEINTRIN_impFPUTC_subr:
5155       {
5156         tree arg1_tree;
5157         tree arg2_tree;
5158         tree arg2_len = integer_zero_node;
5159         tree arg3_tree;
5160
5161         arg1_tree = convert (ffecom_f2c_integer_type_node,
5162                              ffecom_expr (arg1));
5163         arg1_tree = ffecom_1 (ADDR_EXPR,
5164                               build_pointer_type (TREE_TYPE (arg1_tree)),
5165                               arg1_tree);
5166
5167         arg2_tree = ffecom_arg_ptr_to_expr (arg2, &arg2_len);
5168         if (arg3 != NULL)
5169           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5170         else
5171           arg3_tree = NULL_TREE;
5172
5173         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5174         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5175         arg2_len = build_tree_list (NULL_TREE, arg2_len);
5176         TREE_CHAIN (arg1_tree) = arg2_tree;
5177         TREE_CHAIN (arg2_tree) = arg2_len;
5178
5179         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5180                                   ffecom_gfrt_kindtype (gfrt),
5181                                   FALSE,
5182                                   NULL_TREE,
5183                                   arg1_tree,
5184                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5185                                   ffebld_nonter_hook (expr));
5186         if (arg3_tree != NULL_TREE)
5187           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5188                                      convert (TREE_TYPE (arg3_tree),
5189                                               expr_tree));
5190       }
5191       return expr_tree;
5192
5193     case FFEINTRIN_impFSTAT_subr:
5194       {
5195         tree arg1_tree;
5196         tree arg2_tree;
5197         tree arg3_tree;
5198
5199         arg1_tree = convert (ffecom_f2c_integer_type_node,
5200                              ffecom_expr (arg1));
5201         arg1_tree = ffecom_1 (ADDR_EXPR,
5202                               build_pointer_type (TREE_TYPE (arg1_tree)),
5203                               arg1_tree);
5204
5205         arg2_tree = convert (ffecom_f2c_ptr_to_integer_type_node,
5206                              ffecom_ptr_to_expr (arg2));
5207
5208         if (arg3 == NULL)
5209           arg3_tree = NULL_TREE;
5210         else
5211           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5212
5213         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5214         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5215         TREE_CHAIN (arg1_tree) = arg2_tree;
5216         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5217                                   ffecom_gfrt_kindtype (gfrt),
5218                                   FALSE,
5219                                   NULL_TREE,
5220                                   arg1_tree,
5221                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5222                                   ffebld_nonter_hook (expr));
5223         if (arg3_tree != NULL_TREE) {
5224           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5225                                      convert (TREE_TYPE (arg3_tree),
5226                                               expr_tree));
5227         }
5228       }
5229       return expr_tree;
5230
5231     case FFEINTRIN_impKILL_subr:
5232       {
5233         tree arg1_tree;
5234         tree arg2_tree;
5235         tree arg3_tree;
5236
5237         arg1_tree = convert (ffecom_f2c_integer_type_node,
5238                              ffecom_expr (arg1));
5239         arg1_tree = ffecom_1 (ADDR_EXPR,
5240                               build_pointer_type (TREE_TYPE (arg1_tree)),
5241                               arg1_tree);
5242
5243         arg2_tree = convert (ffecom_f2c_integer_type_node,
5244                              ffecom_expr (arg2));
5245         arg2_tree = ffecom_1 (ADDR_EXPR,
5246                               build_pointer_type (TREE_TYPE (arg2_tree)),
5247                               arg2_tree);
5248
5249         if (arg3 == NULL)
5250           arg3_tree = NULL_TREE;
5251         else
5252           arg3_tree = ffecom_expr_w (NULL_TREE, arg3);
5253
5254         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5255         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5256         TREE_CHAIN (arg1_tree) = arg2_tree;
5257         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5258                                   ffecom_gfrt_kindtype (gfrt),
5259                                   FALSE,
5260                                   NULL_TREE,
5261                                   arg1_tree,
5262                                   NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5263                                   ffebld_nonter_hook (expr));
5264         if (arg3_tree != NULL_TREE) {
5265           expr_tree = ffecom_modify (NULL_TREE, arg3_tree,
5266                                      convert (TREE_TYPE (arg3_tree),
5267                                               expr_tree));
5268         }
5269       }
5270       return expr_tree;
5271
5272     case FFEINTRIN_impCTIME_subr:
5273     case FFEINTRIN_impTTYNAM_subr:
5274       {
5275         tree arg1_len = integer_zero_node;
5276         tree arg1_tree;
5277         tree arg2_tree;
5278
5279         arg1_tree = ffecom_arg_ptr_to_expr (arg2, &arg1_len);
5280
5281         arg2_tree = convert (((codegen_imp == FFEINTRIN_impCTIME_subr) ?
5282                               ffecom_f2c_longint_type_node :
5283                               ffecom_f2c_integer_type_node),
5284                              ffecom_expr (arg1));
5285         arg2_tree = ffecom_1 (ADDR_EXPR,
5286                               build_pointer_type (TREE_TYPE (arg2_tree)),
5287                               arg2_tree);
5288
5289         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5290         arg1_len = build_tree_list (NULL_TREE, arg1_len);
5291         arg2_tree = build_tree_list (NULL_TREE, arg2_tree);
5292         TREE_CHAIN (arg1_len) = arg2_tree;
5293         TREE_CHAIN (arg1_tree) = arg1_len;
5294
5295         expr_tree
5296           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5297                           ffecom_gfrt_kindtype (gfrt),
5298                           FALSE,
5299                           NULL_TREE,
5300                           arg1_tree,
5301                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5302                           ffebld_nonter_hook (expr));
5303         TREE_SIDE_EFFECTS (expr_tree) = 1;
5304       }
5305       return expr_tree;
5306
5307     case FFEINTRIN_impIRAND:
5308     case FFEINTRIN_impRAND:
5309       /* Arg defaults to 0 (normal random case) */
5310       {
5311         tree arg1_tree;
5312
5313         if (arg1 == NULL)
5314           arg1_tree = ffecom_integer_zero_node;
5315         else
5316           arg1_tree = ffecom_expr (arg1);
5317         arg1_tree = convert (ffecom_f2c_integer_type_node,
5318                              arg1_tree);
5319         arg1_tree = ffecom_1 (ADDR_EXPR,
5320                               build_pointer_type (TREE_TYPE (arg1_tree)),
5321                               arg1_tree);
5322         arg1_tree = build_tree_list (NULL_TREE, arg1_tree);
5323
5324         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5325                                   ffecom_gfrt_kindtype (gfrt),
5326                                   FALSE,
5327                                   ((codegen_imp == FFEINTRIN_impIRAND) ?
5328                                    ffecom_f2c_integer_type_node :
5329                                    ffecom_f2c_real_type_node),
5330                                   arg1_tree,
5331                                   dest_tree, dest, dest_used,
5332                                   NULL_TREE, TRUE,
5333                                   ffebld_nonter_hook (expr));
5334       }
5335       return expr_tree;
5336
5337     case FFEINTRIN_impFTELL_subr:
5338     case FFEINTRIN_impUMASK_subr:
5339       {
5340         tree arg1_tree;
5341         tree arg2_tree;
5342
5343         arg1_tree = convert (ffecom_f2c_integer_type_node,
5344                              ffecom_expr (arg1));
5345         arg1_tree = ffecom_1 (ADDR_EXPR,
5346                               build_pointer_type (TREE_TYPE (arg1_tree)),
5347                               arg1_tree);
5348
5349         if (arg2 == NULL)
5350           arg2_tree = NULL_TREE;
5351         else
5352           arg2_tree = ffecom_expr_w (NULL_TREE, arg2);
5353
5354         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5355                                   ffecom_gfrt_kindtype (gfrt),
5356                                   FALSE,
5357                                   NULL_TREE,
5358                                   build_tree_list (NULL_TREE, arg1_tree),
5359                                   NULL_TREE, NULL, NULL, NULL_TREE,
5360                                   TRUE,
5361                                   ffebld_nonter_hook (expr));
5362         if (arg2_tree != NULL_TREE) {
5363           expr_tree = ffecom_modify (NULL_TREE, arg2_tree,
5364                                      convert (TREE_TYPE (arg2_tree),
5365                                               expr_tree));
5366         }
5367       }
5368       return expr_tree;
5369
5370     case FFEINTRIN_impCPU_TIME:
5371     case FFEINTRIN_impSECOND_subr:
5372       {
5373         tree arg1_tree;
5374
5375         arg1_tree = ffecom_expr_w (NULL_TREE, arg1);
5376
5377         expr_tree
5378           = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5379                           ffecom_gfrt_kindtype (gfrt),
5380                           FALSE,
5381                           NULL_TREE,
5382                           NULL_TREE,
5383                           NULL_TREE, NULL, NULL, NULL_TREE, TRUE,
5384                           ffebld_nonter_hook (expr));
5385
5386         expr_tree
5387           = ffecom_modify (NULL_TREE, arg1_tree,
5388                            convert (TREE_TYPE (arg1_tree),
5389                                     expr_tree));
5390       }
5391       return expr_tree;
5392
5393     case FFEINTRIN_impDTIME_subr:
5394     case FFEINTRIN_impETIME_subr:
5395       {
5396         tree arg1_tree;
5397         tree result_tree;
5398
5399         result_tree = ffecom_expr_w (NULL_TREE, arg2);
5400
5401         arg1_tree = ffecom_ptr_to_expr (arg1);
5402
5403         expr_tree = ffecom_call_ (ffecom_gfrt_tree_ (gfrt),
5404                                   ffecom_gfrt_kindtype (gfrt),
5405                                   FALSE,
5406                                   NULL_TREE,
5407                                   build_tree_list (NULL_TREE, arg1_tree),
5408                                   NULL_TREE, NULL, NULL, NULL_TREE,
5409                                   TRUE,
5410                                   ffebld_nonter_hook (expr));
5411         expr_tree = ffecom_modify (NULL_TREE, result_tree,
5412                                    convert (TREE_TYPE (result_tree),
5413                                             expr_tree));
5414       }
5415       return expr_tree;
5416
5417       /* Straightforward calls of libf2c routines: */
5418     case FFEINTRIN_impABORT:
5419     case FFEINTRIN_impACCESS:
5420     case FFEINTRIN_impBESJ0:
5421     case FFEINTRIN_impBESJ1:
5422     case FFEINTRIN_impBESJN:
5423     case FFEINTRIN_impBESY0:
5424     case FFEINTRIN_impBESY1:
5425     case FFEINTRIN_impBESYN:
5426     case FFEINTRIN_impCHDIR_func:
5427     case FFEINTRIN_impCHMOD_func:
5428     case FFEINTRIN_impDATE:
5429     case FFEINTRIN_impDATE_AND_TIME:
5430     case FFEINTRIN_impDBESJ0:
5431     case FFEINTRIN_impDBESJ1:
5432     case FFEINTRIN_impDBESJN:
5433     case FFEINTRIN_impDBESY0:
5434     case FFEINTRIN_impDBESY1:
5435     case FFEINTRIN_impDBESYN:
5436     case FFEINTRIN_impDTIME_func:
5437     case FFEINTRIN_impETIME_func:
5438     case FFEINTRIN_impFGETC_func:
5439     case FFEINTRIN_impFGET_func:
5440     case FFEINTRIN_impFNUM:
5441     case FFEINTRIN_impFPUTC_func:
5442     case FFEINTRIN_impFPUT_func:
5443     case FFEINTRIN_impFSEEK:
5444     case FFEINTRIN_impFSTAT_func:
5445     case FFEINTRIN_impFTELL_func:
5446     case FFEINTRIN_impGERROR:
5447     case FFEINTRIN_impGETARG:
5448     case FFEINTRIN_impGETCWD_func:
5449     case FFEINTRIN_impGETENV:
5450     case FFEINTRIN_impGETGID:
5451     case FFEINTRIN_impGETLOG:
5452     case FFEINTRIN_impGETPID:
5453     case FFEINTRIN_impGETUID:
5454     case FFEINTRIN_impGMTIME:
5455     case FFEINTRIN_impHOSTNM_func:
5456     case FFEINTRIN_impIDATE_unix:
5457     case FFEINTRIN_impIDATE_vxt:
5458     case FFEINTRIN_impIERRNO:
5459     case FFEINTRIN_impISATTY:
5460     case FFEINTRIN_impITIME:
5461     case FFEINTRIN_impKILL_func:
5462     case FFEINTRIN_impLINK_func:
5463     case FFEINTRIN_impLNBLNK:
5464     case FFEINTRIN_impLSTAT_func:
5465     case FFEINTRIN_impLTIME:
5466     case FFEINTRIN_impMCLOCK8:
5467     case FFEINTRIN_impMCLOCK:
5468     case FFEINTRIN_impPERROR:
5469     case FFEINTRIN_impRENAME_func:
5470     case FFEINTRIN_impSECNDS:
5471     case FFEINTRIN_impSECOND_func:
5472     case FFEINTRIN_impSLEEP:
5473     case FFEINTRIN_impSRAND:
5474     case FFEINTRIN_impSTAT_func:
5475     case FFEINTRIN_impSYMLNK_func:
5476     case FFEINTRIN_impSYSTEM_CLOCK:
5477     case FFEINTRIN_impSYSTEM_func:
5478     case FFEINTRIN_impTIME8:
5479     case FFEINTRIN_impTIME_unix:
5480     case FFEINTRIN_impTIME_vxt:
5481     case FFEINTRIN_impUMASK_func:
5482     case FFEINTRIN_impUNLINK_func:
5483       break;
5484
5485     case FFEINTRIN_impCTIME_func:       /* CHARACTER functions not handled here. */
5486     case FFEINTRIN_impFDATE_func:       /* CHARACTER functions not handled here. */
5487     case FFEINTRIN_impTTYNAM_func:      /* CHARACTER functions not handled here. */
5488     case FFEINTRIN_impNONE:
5489     case FFEINTRIN_imp:         /* Hush up gcc warning. */
5490       fprintf (stderr, "No %s implementation.\n",
5491                ffeintrin_name_implementation (ffebld_symter_implementation (ffebld_left (expr))));
5492       assert ("unimplemented intrinsic" == NULL);
5493       return error_mark_node;
5494     }
5495
5496   assert (gfrt != FFECOM_gfrt); /* Must have an implementation! */
5497
5498   expr_tree = ffecom_arglist_expr_ (ffecom_gfrt_args_ (gfrt),
5499                                     ffebld_right (expr));
5500
5501   return ffecom_call_ (ffecom_gfrt_tree_ (gfrt), ffecom_gfrt_kindtype (gfrt),
5502                        (ffe_is_f2c_library () && ffecom_gfrt_complex_[gfrt]),
5503                        tree_type,
5504                        expr_tree, dest_tree, dest, dest_used,
5505                        NULL_TREE, TRUE,
5506                        ffebld_nonter_hook (expr));
5507
5508   /* See bottom of this file for f2c transforms used to determine
5509      many of the above implementations.  The info seems to confuse
5510      Emacs's C mode indentation, which is why it's been moved to
5511      the bottom of this source file.  */
5512 }
5513
5514 #endif
5515 /* For power (exponentiation) where right-hand operand is type INTEGER,
5516    generate in-line code to do it the fast way (which, if the operand
5517    is a constant, might just mean a series of multiplies).  */
5518
5519 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5520 static tree
5521 ffecom_expr_power_integer_ (ffebld expr)
5522 {
5523   tree l = ffecom_expr (ffebld_left (expr));
5524   tree r = ffecom_expr (ffebld_right (expr));
5525   tree ltype = TREE_TYPE (l);
5526   tree rtype = TREE_TYPE (r);
5527   tree result = NULL_TREE;
5528
5529   if (l == error_mark_node
5530       || r == error_mark_node)
5531     return error_mark_node;
5532
5533   if (TREE_CODE (r) == INTEGER_CST)
5534     {
5535       int sgn = tree_int_cst_sgn (r);
5536
5537       if (sgn == 0)
5538         return convert (ltype, integer_one_node);
5539
5540       if ((TREE_CODE (ltype) == INTEGER_TYPE)
5541           && (sgn < 0))
5542         {
5543           /* Reciprocal of integer is either 0, -1, or 1, so after
5544              calculating that (which we leave to the back end to do
5545              or not do optimally), don't bother with any multiplying.  */
5546
5547           result = ffecom_tree_divide_ (ltype,
5548                                         convert (ltype, integer_one_node),
5549                                         l,
5550                                         NULL_TREE, NULL, NULL, NULL_TREE);
5551           r = ffecom_1 (NEGATE_EXPR,
5552                         rtype,
5553                         r);
5554           if ((TREE_INT_CST_LOW (r) & 1) == 0)
5555             result = ffecom_1 (ABS_EXPR, rtype,
5556                                result);
5557         }
5558
5559       /* Generate appropriate series of multiplies, preceded
5560          by divide if the exponent is negative.  */
5561
5562       l = save_expr (l);
5563
5564       if (sgn < 0)
5565         {
5566           l = ffecom_tree_divide_ (ltype,
5567                                    convert (ltype, integer_one_node),
5568                                    l,
5569                                    NULL_TREE, NULL, NULL,
5570                                    ffebld_nonter_hook (expr));
5571           r = ffecom_1 (NEGATE_EXPR, rtype, r);
5572           assert (TREE_CODE (r) == INTEGER_CST);
5573
5574           if (tree_int_cst_sgn (r) < 0)
5575             {                   /* The "most negative" number.  */
5576               r = ffecom_1 (NEGATE_EXPR, rtype,
5577                             ffecom_2 (RSHIFT_EXPR, rtype,
5578                                       r,
5579                                       integer_one_node));
5580               l = save_expr (l);
5581               l = ffecom_2 (MULT_EXPR, ltype,
5582                             l,
5583                             l);
5584             }
5585         }
5586
5587       for (;;)
5588         {
5589           if (TREE_INT_CST_LOW (r) & 1)
5590             {
5591               if (result == NULL_TREE)
5592                 result = l;
5593               else
5594                 result = ffecom_2 (MULT_EXPR, ltype,
5595                                    result,
5596                                    l);
5597             }
5598
5599           r = ffecom_2 (RSHIFT_EXPR, rtype,
5600                         r,
5601                         integer_one_node);
5602           if (integer_zerop (r))
5603             break;
5604           assert (TREE_CODE (r) == INTEGER_CST);
5605
5606           l = save_expr (l);
5607           l = ffecom_2 (MULT_EXPR, ltype,
5608                         l,
5609                         l);
5610         }
5611       return result;
5612     }
5613
5614   /* Though rhs isn't a constant, in-line code cannot be expanded
5615      while transforming dummies
5616      because the back end cannot be easily convinced to generate
5617      stores (MODIFY_EXPR), handle temporaries, and so on before
5618      all the appropriate rtx's have been generated for things like
5619      dummy args referenced in rhs -- which doesn't happen until
5620      store_parm_decls() is called (expand_function_start, I believe,
5621      does the actual rtx-stuffing of PARM_DECLs).
5622
5623      So, in this case, let the caller generate the call to the
5624      run-time-library function to evaluate the power for us.  */
5625
5626   if (ffecom_transform_only_dummies_)
5627     return NULL_TREE;
5628
5629   /* Right-hand operand not a constant, expand in-line code to figure
5630      out how to do the multiplies, &c.
5631
5632      The returned expression is expressed this way in GNU C, where l and
5633      r are the "inputs":
5634
5635      ({ typeof (r) rtmp = r;
5636         typeof (l) ltmp = l;
5637         typeof (l) result;
5638
5639         if (rtmp == 0)
5640           result = 1;
5641         else
5642           {
5643             if ((basetypeof (l) == basetypeof (int))
5644                 && (rtmp < 0))
5645               {
5646                 result = ((typeof (l)) 1) / ltmp;
5647                 if ((ltmp < 0) && (((-rtmp) & 1) == 0))
5648                   result = -result;
5649               }
5650             else
5651               {
5652                 result = 1;
5653                 if ((basetypeof (l) != basetypeof (int))
5654                     && (rtmp < 0))
5655                   {
5656                     ltmp = ((typeof (l)) 1) / ltmp;
5657                     rtmp = -rtmp;
5658                     if (rtmp < 0)
5659                       {
5660                         rtmp = -(rtmp >> 1);
5661                         ltmp *= ltmp;
5662                       }
5663                   }
5664                 for (;;)
5665                   {
5666                     if (rtmp & 1)
5667                       result *= ltmp;
5668                     if ((rtmp >>= 1) == 0)
5669                       break;
5670                     ltmp *= ltmp;
5671                   }
5672               }
5673           }
5674         result;
5675      })
5676
5677      Note that some of the above is compile-time collapsable, such as
5678      the first part of the if statements that checks the base type of
5679      l against int.  The if statements are phrased that way to suggest
5680      an easy way to generate the if/else constructs here, knowing that
5681      the back end should (and probably does) eliminate the resulting
5682      dead code (either the int case or the non-int case), something
5683      it couldn't do without the redundant phrasing, requiring explicit
5684      dead-code elimination here, which would be kind of difficult to
5685      read.  */
5686
5687   {
5688     tree rtmp;
5689     tree ltmp;
5690     tree divide;
5691     tree basetypeof_l_is_int;
5692     tree se;
5693     tree t;
5694
5695     basetypeof_l_is_int
5696       = build_int_2 ((TREE_CODE (ltype) == INTEGER_TYPE), 0);
5697
5698     se = expand_start_stmt_expr ();
5699
5700     ffecom_start_compstmt ();
5701
5702 #ifndef HAHA
5703     rtmp = ffecom_make_tempvar ("power_r", rtype,
5704                                 FFETARGET_charactersizeNONE, -1);
5705     ltmp = ffecom_make_tempvar ("power_l", ltype,
5706                                 FFETARGET_charactersizeNONE, -1);
5707     result = ffecom_make_tempvar ("power_res", ltype,
5708                                   FFETARGET_charactersizeNONE, -1);
5709     if (TREE_CODE (ltype) == COMPLEX_TYPE
5710         || TREE_CODE (ltype) == RECORD_TYPE)
5711       divide = ffecom_make_tempvar ("power_div", ltype,
5712                                     FFETARGET_charactersizeNONE, -1);
5713     else
5714       divide = NULL_TREE;
5715 #else  /* HAHA */
5716     {
5717       tree hook;
5718
5719       hook = ffebld_nonter_hook (expr);
5720       assert (hook);
5721       assert (TREE_CODE (hook) == TREE_VEC);
5722       assert (TREE_VEC_LENGTH (hook) == 4);
5723       rtmp = TREE_VEC_ELT (hook, 0);
5724       ltmp = TREE_VEC_ELT (hook, 1);
5725       result = TREE_VEC_ELT (hook, 2);
5726       divide = TREE_VEC_ELT (hook, 3);
5727       if (TREE_CODE (ltype) == COMPLEX_TYPE
5728           || TREE_CODE (ltype) == RECORD_TYPE)
5729         assert (divide);
5730       else
5731         assert (! divide);
5732     }
5733 #endif  /* HAHA */
5734
5735     expand_expr_stmt (ffecom_modify (void_type_node,
5736                                      rtmp,
5737                                      r));
5738     expand_expr_stmt (ffecom_modify (void_type_node,
5739                                      ltmp,
5740                                      l));
5741     expand_start_cond (ffecom_truth_value
5742                        (ffecom_2 (EQ_EXPR, integer_type_node,
5743                                   rtmp,
5744                                   convert (rtype, integer_zero_node))),
5745                        0);
5746     expand_expr_stmt (ffecom_modify (void_type_node,
5747                                      result,
5748                                      convert (ltype, integer_one_node)));
5749     expand_start_else ();
5750     if (! integer_zerop (basetypeof_l_is_int))
5751       {
5752         expand_start_cond (ffecom_2 (LT_EXPR, integer_type_node,
5753                                      rtmp,
5754                                      convert (rtype,
5755                                               integer_zero_node)),
5756                            0);
5757         expand_expr_stmt (ffecom_modify (void_type_node,
5758                                          result,
5759                                          ffecom_tree_divide_
5760                                          (ltype,
5761                                           convert (ltype, integer_one_node),
5762                                           ltmp,
5763                                           NULL_TREE, NULL, NULL,
5764                                           divide)));
5765         expand_start_cond (ffecom_truth_value
5766                            (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5767                                       ffecom_2 (LT_EXPR, integer_type_node,
5768                                                 ltmp,
5769                                                 convert (ltype,
5770                                                          integer_zero_node)),
5771                                       ffecom_2 (EQ_EXPR, integer_type_node,
5772                                                 ffecom_2 (BIT_AND_EXPR,
5773                                                           rtype,
5774                                                           ffecom_1 (NEGATE_EXPR,
5775                                                                     rtype,
5776                                                                     rtmp),
5777                                                           convert (rtype,
5778                                                                    integer_one_node)),
5779                                                 convert (rtype,
5780                                                          integer_zero_node)))),
5781                            0);
5782         expand_expr_stmt (ffecom_modify (void_type_node,
5783                                          result,
5784                                          ffecom_1 (NEGATE_EXPR,
5785                                                    ltype,
5786                                                    result)));
5787         expand_end_cond ();
5788         expand_start_else ();
5789       }
5790     expand_expr_stmt (ffecom_modify (void_type_node,
5791                                      result,
5792                                      convert (ltype, integer_one_node)));
5793     expand_start_cond (ffecom_truth_value
5794                        (ffecom_2 (TRUTH_ANDIF_EXPR, integer_type_node,
5795                                   ffecom_truth_value_invert
5796                                   (basetypeof_l_is_int),
5797                                   ffecom_2 (LT_EXPR, integer_type_node,
5798                                             rtmp,
5799                                             convert (rtype,
5800                                                      integer_zero_node)))),
5801                        0);
5802     expand_expr_stmt (ffecom_modify (void_type_node,
5803                                      ltmp,
5804                                      ffecom_tree_divide_
5805                                      (ltype,
5806                                       convert (ltype, integer_one_node),
5807                                       ltmp,
5808                                       NULL_TREE, NULL, NULL,
5809                                       divide)));
5810     expand_expr_stmt (ffecom_modify (void_type_node,
5811                                      rtmp,
5812                                      ffecom_1 (NEGATE_EXPR, rtype,
5813                                                rtmp)));
5814     expand_start_cond (ffecom_truth_value
5815                        (ffecom_2 (LT_EXPR, integer_type_node,
5816                                   rtmp,
5817                                   convert (rtype, integer_zero_node))),
5818                        0);
5819     expand_expr_stmt (ffecom_modify (void_type_node,
5820                                      rtmp,
5821                                      ffecom_1 (NEGATE_EXPR, rtype,
5822                                                ffecom_2 (RSHIFT_EXPR,
5823                                                          rtype,
5824                                                          rtmp,
5825                                                          integer_one_node))));
5826     expand_expr_stmt (ffecom_modify (void_type_node,
5827                                      ltmp,
5828                                      ffecom_2 (MULT_EXPR, ltype,
5829                                                ltmp,
5830                                                ltmp)));
5831     expand_end_cond ();
5832     expand_end_cond ();
5833     expand_start_loop (1);
5834     expand_start_cond (ffecom_truth_value
5835                        (ffecom_2 (BIT_AND_EXPR, rtype,
5836                                   rtmp,
5837                                   convert (rtype, integer_one_node))),
5838                        0);
5839     expand_expr_stmt (ffecom_modify (void_type_node,
5840                                      result,
5841                                      ffecom_2 (MULT_EXPR, ltype,
5842                                                result,
5843                                                ltmp)));
5844     expand_end_cond ();
5845     expand_exit_loop_if_false (NULL,
5846                                ffecom_truth_value
5847                                (ffecom_modify (rtype,
5848                                                rtmp,
5849                                                ffecom_2 (RSHIFT_EXPR,
5850                                                          rtype,
5851                                                          rtmp,
5852                                                          integer_one_node))));
5853     expand_expr_stmt (ffecom_modify (void_type_node,
5854                                      ltmp,
5855                                      ffecom_2 (MULT_EXPR, ltype,
5856                                                ltmp,
5857                                                ltmp)));
5858     expand_end_loop ();
5859     expand_end_cond ();
5860     if (!integer_zerop (basetypeof_l_is_int))
5861       expand_end_cond ();
5862     expand_expr_stmt (result);
5863
5864     t = ffecom_end_compstmt ();
5865
5866     result = expand_end_stmt_expr (se);
5867
5868     /* This code comes from c-parse.in, after its expand_end_stmt_expr.  */
5869
5870     if (TREE_CODE (t) == BLOCK)
5871       {
5872         /* Make a BIND_EXPR for the BLOCK already made.  */
5873         result = build (BIND_EXPR, TREE_TYPE (result),
5874                         NULL_TREE, result, t);
5875         /* Remove the block from the tree at this point.
5876            It gets put back at the proper place
5877            when the BIND_EXPR is expanded.  */
5878         delete_block (t);
5879       }
5880     else
5881       result = t;
5882   }
5883
5884   return result;
5885 }
5886
5887 #endif
5888 /* ffecom_expr_transform_ -- Transform symbols in expr
5889
5890    ffebld expr;  // FFE expression.
5891    ffecom_expr_transform_ (expr);
5892
5893    Recursive descent on expr while transforming any untransformed SYMTERs.  */
5894
5895 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5896 static void
5897 ffecom_expr_transform_ (ffebld expr)
5898 {
5899   tree t;
5900   ffesymbol s;
5901
5902 tail_recurse:                   /* :::::::::::::::::::: */
5903
5904   if (expr == NULL)
5905     return;
5906
5907   switch (ffebld_op (expr))
5908     {
5909     case FFEBLD_opSYMTER:
5910       s = ffebld_symter (expr);
5911       t = ffesymbol_hook (s).decl_tree;
5912       if ((t == NULL_TREE)
5913           && ((ffesymbol_kind (s) != FFEINFO_kindNONE)
5914               || ((ffesymbol_where (s) != FFEINFO_whereNONE)
5915                   && (ffesymbol_where (s) != FFEINFO_whereINTRINSIC))))
5916         {
5917           s = ffecom_sym_transform_ (s);
5918           t = ffesymbol_hook (s).decl_tree;     /* Sfunc expr non-dummy,
5919                                                    DIMENSION expr? */
5920         }
5921       break;                    /* Ok if (t == NULL) here. */
5922
5923     case FFEBLD_opITEM:
5924       ffecom_expr_transform_ (ffebld_head (expr));
5925       expr = ffebld_trail (expr);
5926       goto tail_recurse;        /* :::::::::::::::::::: */
5927
5928     default:
5929       break;
5930     }
5931
5932   switch (ffebld_arity (expr))
5933     {
5934     case 2:
5935       ffecom_expr_transform_ (ffebld_left (expr));
5936       expr = ffebld_right (expr);
5937       goto tail_recurse;        /* :::::::::::::::::::: */
5938
5939     case 1:
5940       expr = ffebld_left (expr);
5941       goto tail_recurse;        /* :::::::::::::::::::: */
5942
5943     default:
5944       break;
5945     }
5946
5947   return;
5948 }
5949
5950 #endif
5951 /* Make a type based on info in live f2c.h file.  */
5952
5953 #if FFECOM_targetCURRENT == FFECOM_targetGCC
5954 static void
5955 ffecom_f2c_make_type_ (tree *type, int tcode, const char *name)
5956 {
5957   switch (tcode)
5958     {
5959     case FFECOM_f2ccodeCHAR:
5960       *type = make_signed_type (CHAR_TYPE_SIZE);
5961       break;
5962
5963     case FFECOM_f2ccodeSHORT:
5964       *type = make_signed_type (SHORT_TYPE_SIZE);
5965       break;
5966
5967     case FFECOM_f2ccodeINT:
5968       *type = make_signed_type (INT_TYPE_SIZE);
5969       break;
5970
5971     case FFECOM_f2ccodeLONG:
5972       *type = make_signed_type (LONG_TYPE_SIZE);
5973       break;
5974
5975     case FFECOM_f2ccodeLONGLONG:
5976       *type = make_signed_type (LONG_LONG_TYPE_SIZE);
5977       break;
5978
5979     case FFECOM_f2ccodeCHARPTR:
5980       *type = build_pointer_type (DEFAULT_SIGNED_CHAR
5981                                   ? signed_char_type_node
5982                                   : unsigned_char_type_node);
5983       break;
5984
5985     case FFECOM_f2ccodeFLOAT:
5986       *type = make_node (REAL_TYPE);
5987       TYPE_PRECISION (*type) = FLOAT_TYPE_SIZE;
5988       layout_type (*type);
5989       break;
5990
5991     case FFECOM_f2ccodeDOUBLE:
5992       *type = make_node (REAL_TYPE);
5993       TYPE_PRECISION (*type) = DOUBLE_TYPE_SIZE;
5994       layout_type (*type);
5995       break;
5996
5997     case FFECOM_f2ccodeLONGDOUBLE:
5998       *type = make_node (REAL_TYPE);
5999       TYPE_PRECISION (*type) = LONG_DOUBLE_TYPE_SIZE;
6000       layout_type (*type);
6001       break;
6002
6003     case FFECOM_f2ccodeTWOREALS:
6004       *type = ffecom_make_complex_type_ (ffecom_f2c_real_type_node);
6005       break;
6006
6007     case FFECOM_f2ccodeTWODOUBLEREALS:
6008       *type = ffecom_make_complex_type_ (ffecom_f2c_doublereal_type_node);
6009       break;
6010
6011     default:
6012       assert ("unexpected FFECOM_f2ccodeXYZZY!" == NULL);
6013       *type = error_mark_node;
6014       return;
6015     }
6016
6017   pushdecl (build_decl (TYPE_DECL,
6018                         ffecom_get_invented_identifier ("__g77_f2c_%s", name),
6019                         *type));
6020 }
6021
6022 #endif
6023 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6024 /* Set the f2c list-directed-I/O code for whatever (integral) type has the
6025    given size.  */
6026
6027 static void
6028 ffecom_f2c_set_lio_code_ (ffeinfoBasictype bt, int size,
6029                           int code)
6030 {
6031   int j;
6032   tree t;
6033
6034   for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
6035     if ((t = ffecom_tree_type[bt][j]) != NULL_TREE
6036         && compare_tree_int (TYPE_SIZE (t), size) == 0)
6037       {
6038         assert (code != -1);
6039         ffecom_f2c_typecode_[bt][j] = code;
6040         code = -1;
6041       }
6042 }
6043
6044 #endif
6045 /* Finish up globals after doing all program units in file
6046
6047    Need to handle only uninitialized COMMON areas.  */
6048
6049 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6050 static ffeglobal
6051 ffecom_finish_global_ (ffeglobal global)
6052 {
6053   tree cbtype;
6054   tree cbt;
6055   tree size;
6056
6057   if (ffeglobal_type (global) != FFEGLOBAL_typeCOMMON)
6058       return global;
6059
6060   if (ffeglobal_common_init (global))
6061       return global;
6062
6063   cbt = ffeglobal_hook (global);
6064   if ((cbt == NULL_TREE)
6065       || !ffeglobal_common_have_size (global))
6066     return global;              /* No need to make common, never ref'd. */
6067
6068   DECL_EXTERNAL (cbt) = 0;
6069
6070   /* Give the array a size now.  */
6071
6072   size = build_int_2 ((ffeglobal_common_size (global)
6073                       + ffeglobal_common_pad (global)) - 1,
6074                       0);
6075
6076   cbtype = TREE_TYPE (cbt);
6077   TYPE_DOMAIN (cbtype) = build_range_type (integer_type_node,
6078                                            integer_zero_node,
6079                                            size);
6080   if (!TREE_TYPE (size))
6081     TREE_TYPE (size) = TYPE_DOMAIN (cbtype);
6082   layout_type (cbtype);
6083
6084   cbt = start_decl (cbt, FALSE);
6085   assert (cbt == ffeglobal_hook (global));
6086
6087   finish_decl (cbt, NULL_TREE, FALSE);
6088
6089   return global;
6090 }
6091
6092 #endif
6093 /* Finish up any untransformed symbols.  */
6094
6095 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6096 static ffesymbol
6097 ffecom_finish_symbol_transform_ (ffesymbol s)
6098 {
6099   if ((s == NULL) || (TREE_CODE (current_function_decl) == ERROR_MARK))
6100     return s;
6101
6102   /* It's easy to know to transform an untransformed symbol, to make sure
6103      we put out debugging info for it.  But COMMON variables, unlike
6104      EQUIVALENCE ones, aren't given declarations in addition to the
6105      tree expressions that specify offsets, because COMMON variables
6106      can be referenced in the outer scope where only dummy arguments
6107      (PARM_DECLs) should really be seen.  To be safe, just don't do any
6108      VAR_DECLs for COMMON variables when we transform them for real
6109      use, and therefore we do all the VAR_DECL creating here.  */
6110
6111   if (ffesymbol_hook (s).decl_tree == NULL_TREE)
6112     {
6113       if (ffesymbol_kind (s) != FFEINFO_kindNONE
6114           || (ffesymbol_where (s) != FFEINFO_whereNONE
6115               && ffesymbol_where (s) != FFEINFO_whereINTRINSIC
6116               && ffesymbol_where (s) != FFEINFO_whereDUMMY))
6117         /* Not transformed, and not CHARACTER*(*), and not a dummy
6118            argument, which can happen only if the entry point names
6119            it "rides in on" are all invalidated for other reasons.  */
6120         s = ffecom_sym_transform_ (s);
6121     }
6122
6123   if ((ffesymbol_where (s) == FFEINFO_whereCOMMON)
6124       && (ffesymbol_hook (s).decl_tree != error_mark_node))
6125     {
6126       /* This isn't working, at least for dbxout.  The .s file looks
6127          okay to me (burley), but in gdb 4.9 at least, the variables
6128          appear to reside somewhere outside of the common area, so
6129          it doesn't make sense to mislead anyone by generating the info
6130          on those variables until this is fixed.  NOTE: Same problem
6131          with EQUIVALENCE, sadly...see similar #if later.  */
6132       ffecom_member_phase2_ (ffesymbol_storage (ffesymbol_common (s)),
6133                              ffesymbol_storage (s));
6134     }
6135
6136   return s;
6137 }
6138
6139 #endif
6140 /* Append underscore(s) to name before calling get_identifier.  "us"
6141    is nonzero if the name already contains an underscore and thus
6142    needs two underscores appended.  */
6143
6144 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6145 static tree
6146 ffecom_get_appended_identifier_ (char us, const char *name)
6147 {
6148   int i;
6149   char *newname;
6150   tree id;
6151
6152   newname = xmalloc ((i = strlen (name)) + 1
6153                      + ffe_is_underscoring ()
6154                      + us);
6155   memcpy (newname, name, i);
6156   newname[i] = '_';
6157   newname[i + us] = '_';
6158   newname[i + 1 + us] = '\0';
6159   id = get_identifier (newname);
6160
6161   free (newname);
6162
6163   return id;
6164 }
6165
6166 #endif
6167 /* Decide whether to append underscore to name before calling
6168    get_identifier.  */
6169
6170 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6171 static tree
6172 ffecom_get_external_identifier_ (ffesymbol s)
6173 {
6174   char us;
6175   const char *name = ffesymbol_text (s);
6176
6177   /* If name is a built-in name, just return it as is.  */
6178
6179   if (!ffe_is_underscoring ()
6180       || (strcmp (name, FFETARGET_nameBLANK_COMMON) == 0)
6181 #if FFETARGET_isENFORCED_MAIN_NAME
6182       || (strcmp (name, FFETARGET_nameENFORCED_NAME) == 0)
6183 #else
6184       || (strcmp (name, FFETARGET_nameUNNAMED_MAIN) == 0)
6185 #endif
6186       || (strcmp (name, FFETARGET_nameUNNAMED_BLOCK_DATA) == 0))
6187     return get_identifier (name);
6188
6189   us = ffe_is_second_underscore ()
6190     ? (strchr (name, '_') != NULL)
6191       : 0;
6192
6193   return ffecom_get_appended_identifier_ (us, name);
6194 }
6195
6196 #endif
6197 /* Decide whether to append underscore to internal name before calling
6198    get_identifier.
6199
6200    This is for non-external, top-function-context names only.  Transform
6201    identifier so it doesn't conflict with the transformed result
6202    of using a _different_ external name.  E.g. if "CALL FOO" is
6203    transformed into "FOO_();", then the variable in "FOO_ = 3"
6204    must be transformed into something that does not conflict, since
6205    these two things should be independent.
6206
6207    The transformation is as follows.  If the name does not contain
6208    an underscore, there is no possible conflict, so just return.
6209    If the name does contain an underscore, then transform it just
6210    like we transform an external identifier.  */
6211
6212 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6213 static tree
6214 ffecom_get_identifier_ (const char *name)
6215 {
6216   /* If name does not contain an underscore, just return it as is.  */
6217
6218   if (!ffe_is_underscoring ()
6219       || (strchr (name, '_') == NULL))
6220     return get_identifier (name);
6221
6222   return ffecom_get_appended_identifier_ (ffe_is_second_underscore (),
6223                                           name);
6224 }
6225
6226 #endif
6227 /* ffecom_gen_sfuncdef_ -- Generate definition of statement function
6228
6229    tree t;
6230    ffesymbol s;  // kindFUNCTION, whereIMMEDIATE.
6231    t = ffecom_gen_sfuncdef_(s,ffesymbol_basictype(s),
6232          ffesymbol_kindtype(s));
6233
6234    Call after setting up containing function and getting trees for all
6235    other symbols.  */
6236
6237 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6238 static tree
6239 ffecom_gen_sfuncdef_ (ffesymbol s, ffeinfoBasictype bt, ffeinfoKindtype kt)
6240 {
6241   ffebld expr = ffesymbol_sfexpr (s);
6242   tree type;
6243   tree func;
6244   tree result;
6245   bool charfunc = (bt == FFEINFO_basictypeCHARACTER);
6246   static bool recurse = FALSE;
6247   int old_lineno = lineno;
6248   const char *old_input_filename = input_filename;
6249
6250   ffecom_nested_entry_ = s;
6251
6252   /* For now, we don't have a handy pointer to where the sfunc is actually
6253      defined, though that should be easy to add to an ffesymbol. (The
6254      token/where info available might well point to the place where the type
6255      of the sfunc is declared, especially if that precedes the place where
6256      the sfunc itself is defined, which is typically the case.)  We should
6257      put out a null pointer rather than point somewhere wrong, but I want to
6258      see how it works at this point.  */
6259
6260   input_filename = ffesymbol_where_filename (s);
6261   lineno = ffesymbol_where_filelinenum (s);
6262
6263   /* Pretransform the expression so any newly discovered things belong to the
6264      outer program unit, not to the statement function. */
6265
6266   ffecom_expr_transform_ (expr);
6267
6268   /* Make sure no recursive invocation of this fn (a specific case of failing
6269      to pretransform an sfunc's expression, i.e. where its expression
6270      references another untransformed sfunc) happens. */
6271
6272   assert (!recurse);
6273   recurse = TRUE;
6274
6275   push_f_function_context ();
6276
6277   if (charfunc)
6278     type = void_type_node;
6279   else
6280     {
6281       type = ffecom_tree_type[bt][kt];
6282       if (type == NULL_TREE)
6283         type = integer_type_node;       /* _sym_exec_transition reports
6284                                            error. */
6285     }
6286
6287   start_function (ffecom_get_identifier_ (ffesymbol_text (s)),
6288                   build_function_type (type, NULL_TREE),
6289                   1,            /* nested/inline */
6290                   0);           /* TREE_PUBLIC */
6291
6292   /* We don't worry about COMPLEX return values here, because this is
6293      entirely internal to our code, and gcc has the ability to return COMPLEX
6294      directly as a value.  */
6295
6296   if (charfunc)
6297     {                           /* Prepend arg for where result goes. */
6298       tree type;
6299
6300       type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
6301
6302       result = ffecom_get_invented_identifier ("__g77_%s", "result");
6303
6304       ffecom_char_enhance_arg_ (&type, s);      /* Ignore returned length. */
6305
6306       type = build_pointer_type (type);
6307       result = build_decl (PARM_DECL, result, type);
6308
6309       push_parm_decl (result);
6310     }
6311   else
6312     result = NULL_TREE;         /* Not ref'd if !charfunc. */
6313
6314   ffecom_push_dummy_decls_ (ffesymbol_dummyargs (s), TRUE);
6315
6316   store_parm_decls (0);
6317
6318   ffecom_start_compstmt ();
6319
6320   if (expr != NULL)
6321     {
6322       if (charfunc)
6323         {
6324           ffetargetCharacterSize sz = ffesymbol_size (s);
6325           tree result_length;
6326
6327           result_length = build_int_2 (sz, 0);
6328           TREE_TYPE (result_length) = ffecom_f2c_ftnlen_type_node;
6329
6330           ffecom_prepare_let_char_ (sz, expr);
6331
6332           ffecom_prepare_end ();
6333
6334           ffecom_let_char_ (result, result_length, sz, expr);
6335           expand_null_return ();
6336         }
6337       else
6338         {
6339           ffecom_prepare_expr (expr);
6340
6341           ffecom_prepare_end ();
6342
6343           expand_return (ffecom_modify (NULL_TREE,
6344                                         DECL_RESULT (current_function_decl),
6345                                         ffecom_expr (expr)));
6346         }
6347     }
6348
6349   ffecom_end_compstmt ();
6350
6351   func = current_function_decl;
6352   finish_function (1);
6353
6354   pop_f_function_context ();
6355
6356   recurse = FALSE;
6357
6358   lineno = old_lineno;
6359   input_filename = old_input_filename;
6360
6361   ffecom_nested_entry_ = NULL;
6362
6363   return func;
6364 }
6365
6366 #endif
6367
6368 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6369 static const char *
6370 ffecom_gfrt_args_ (ffecomGfrt ix)
6371 {
6372   return ffecom_gfrt_argstring_[ix];
6373 }
6374
6375 #endif
6376 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6377 static tree
6378 ffecom_gfrt_tree_ (ffecomGfrt ix)
6379 {
6380   if (ffecom_gfrt_[ix] == NULL_TREE)
6381     ffecom_make_gfrt_ (ix);
6382
6383   return ffecom_1 (ADDR_EXPR,
6384                    build_pointer_type (TREE_TYPE (ffecom_gfrt_[ix])),
6385                    ffecom_gfrt_[ix]);
6386 }
6387
6388 #endif
6389 /* Return initialize-to-zero expression for this VAR_DECL.  */
6390
6391 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6392 /* A somewhat evil way to prevent the garbage collector
6393    from collecting 'tree' structures.  */
6394 #define NUM_TRACKED_CHUNK 63
6395 static struct tree_ggc_tracker
6396 {
6397   struct tree_ggc_tracker *next;
6398   tree trees[NUM_TRACKED_CHUNK];
6399 } *tracker_head = NULL;
6400
6401 static void
6402 mark_tracker_head (void *arg)
6403 {
6404   struct tree_ggc_tracker *head;
6405   int i;
6406
6407   for (head = * (struct tree_ggc_tracker **) arg;
6408        head != NULL;
6409        head = head->next)
6410   {
6411     ggc_mark (head);
6412     for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6413       ggc_mark_tree (head->trees[i]);
6414   }
6415 }
6416
6417 void
6418 ffecom_save_tree_forever (tree t)
6419 {
6420   int i;
6421   if (tracker_head != NULL)
6422     for (i = 0; i < NUM_TRACKED_CHUNK; i++)
6423       if (tracker_head->trees[i] == NULL)
6424         {
6425           tracker_head->trees[i] = t;
6426           return;
6427         }
6428
6429   {
6430     /* Need to allocate a new block.  */
6431     struct tree_ggc_tracker *old_head = tracker_head;
6432
6433     tracker_head = ggc_alloc (sizeof (*tracker_head));
6434     tracker_head->next = old_head;
6435     tracker_head->trees[0] = t;
6436     for (i = 1; i < NUM_TRACKED_CHUNK; i++)
6437       tracker_head->trees[i] = NULL;
6438   }
6439 }
6440
6441 static tree
6442 ffecom_init_zero_ (tree decl)
6443 {
6444   tree init;
6445   int incremental = TREE_STATIC (decl);
6446   tree type = TREE_TYPE (decl);
6447
6448   if (incremental)
6449     {
6450       make_decl_rtl (decl, NULL);
6451       assemble_variable (decl, TREE_PUBLIC (decl) ? 1 : 0, 0, 1);
6452     }
6453
6454   if ((TREE_CODE (type) != ARRAY_TYPE)
6455       && (TREE_CODE (type) != RECORD_TYPE)
6456       && (TREE_CODE (type) != UNION_TYPE)
6457       && !incremental)
6458     init = convert (type, integer_zero_node);
6459   else if (!incremental)
6460     {
6461       init = build (CONSTRUCTOR, type, NULL_TREE, NULL_TREE);
6462       TREE_CONSTANT (init) = 1;
6463       TREE_STATIC (init) = 1;
6464     }
6465   else
6466     {
6467       assemble_zeros (int_size_in_bytes (type));
6468       init = error_mark_node;
6469     }
6470
6471   return init;
6472 }
6473
6474 #endif
6475 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6476 static tree
6477 ffecom_intrinsic_ichar_ (tree tree_type, ffebld arg,
6478                          tree *maybe_tree)
6479 {
6480   tree expr_tree;
6481   tree length_tree;
6482
6483   switch (ffebld_op (arg))
6484     {
6485     case FFEBLD_opCONTER:       /* For F90, check 0-length. */
6486       if (ffetarget_length_character1
6487           (ffebld_constant_character1
6488            (ffebld_conter (arg))) == 0)
6489         {
6490           *maybe_tree = integer_zero_node;
6491           return convert (tree_type, integer_zero_node);
6492         }
6493
6494       *maybe_tree = integer_one_node;
6495       expr_tree = build_int_2 (*ffetarget_text_character1
6496                                (ffebld_constant_character1
6497                                 (ffebld_conter (arg))),
6498                                0);
6499       TREE_TYPE (expr_tree) = tree_type;
6500       return expr_tree;
6501
6502     case FFEBLD_opSYMTER:
6503     case FFEBLD_opARRAYREF:
6504     case FFEBLD_opFUNCREF:
6505     case FFEBLD_opSUBSTR:
6506       ffecom_char_args_ (&expr_tree, &length_tree, arg);
6507
6508       if ((expr_tree == error_mark_node)
6509           || (length_tree == error_mark_node))
6510         {
6511           *maybe_tree = error_mark_node;
6512           return error_mark_node;
6513         }
6514
6515       if (integer_zerop (length_tree))
6516         {
6517           *maybe_tree = integer_zero_node;
6518           return convert (tree_type, integer_zero_node);
6519         }
6520
6521       expr_tree
6522         = ffecom_1 (INDIRECT_REF,
6523                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6524                     expr_tree);
6525       expr_tree
6526         = ffecom_2 (ARRAY_REF,
6527                     TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (expr_tree))),
6528                     expr_tree,
6529                     integer_one_node);
6530       expr_tree = convert (tree_type, expr_tree);
6531
6532       if (TREE_CODE (length_tree) == INTEGER_CST)
6533         *maybe_tree = integer_one_node;
6534       else                      /* Must check length at run time.  */
6535         *maybe_tree
6536           = ffecom_truth_value
6537             (ffecom_2 (GT_EXPR, integer_type_node,
6538                        length_tree,
6539                        ffecom_f2c_ftnlen_zero_node));
6540       return expr_tree;
6541
6542     case FFEBLD_opPAREN:
6543     case FFEBLD_opCONVERT:
6544       if (ffeinfo_size (ffebld_info (arg)) == 0)
6545         {
6546           *maybe_tree = integer_zero_node;
6547           return convert (tree_type, integer_zero_node);
6548         }
6549       return ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6550                                       maybe_tree);
6551
6552     case FFEBLD_opCONCATENATE:
6553       {
6554         tree maybe_left;
6555         tree maybe_right;
6556         tree expr_left;
6557         tree expr_right;
6558
6559         expr_left = ffecom_intrinsic_ichar_ (tree_type, ffebld_left (arg),
6560                                              &maybe_left);
6561         expr_right = ffecom_intrinsic_ichar_ (tree_type, ffebld_right (arg),
6562                                               &maybe_right);
6563         *maybe_tree = ffecom_2 (TRUTH_ORIF_EXPR, integer_type_node,
6564                                 maybe_left,
6565                                 maybe_right);
6566         expr_tree = ffecom_3 (COND_EXPR, tree_type,
6567                               maybe_left,
6568                               expr_left,
6569                               expr_right);
6570         return expr_tree;
6571       }
6572
6573     default:
6574       assert ("bad op in ICHAR" == NULL);
6575       return error_mark_node;
6576     }
6577 }
6578
6579 #endif
6580 /* ffecom_intrinsic_len_ -- Return length info for char arg (LEN())
6581
6582    tree length_arg;
6583    ffebld expr;
6584    length_arg = ffecom_intrinsic_len_ (expr);
6585
6586    Handles CHARACTER-type CONTER, SYMTER, SUBSTR, ARRAYREF, and FUNCREF
6587    subexpressions by constructing the appropriate tree for the
6588    length-of-character-text argument in a calling sequence.  */
6589
6590 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6591 static tree
6592 ffecom_intrinsic_len_ (ffebld expr)
6593 {
6594   ffetargetCharacter1 val;
6595   tree length;
6596
6597   switch (ffebld_op (expr))
6598     {
6599     case FFEBLD_opCONTER:
6600       val = ffebld_constant_character1 (ffebld_conter (expr));
6601       length = build_int_2 (ffetarget_length_character1 (val), 0);
6602       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6603       break;
6604
6605     case FFEBLD_opSYMTER:
6606       {
6607         ffesymbol s = ffebld_symter (expr);
6608         tree item;
6609
6610         item = ffesymbol_hook (s).decl_tree;
6611         if (item == NULL_TREE)
6612           {
6613             s = ffecom_sym_transform_ (s);
6614             item = ffesymbol_hook (s).decl_tree;
6615           }
6616         if (ffesymbol_kind (s) == FFEINFO_kindENTITY)
6617           {
6618             if (ffesymbol_size (s) == FFETARGET_charactersizeNONE)
6619               length = ffesymbol_hook (s).length_tree;
6620             else
6621               {
6622                 length = build_int_2 (ffesymbol_size (s), 0);
6623                 TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6624               }
6625           }
6626         else if (item == error_mark_node)
6627           length = error_mark_node;
6628         else                    /* FFEINFO_kindFUNCTION: */
6629           length = NULL_TREE;
6630       }
6631       break;
6632
6633     case FFEBLD_opARRAYREF:
6634       length = ffecom_intrinsic_len_ (ffebld_left (expr));
6635       break;
6636
6637     case FFEBLD_opSUBSTR:
6638       {
6639         ffebld start;
6640         ffebld end;
6641         ffebld thing = ffebld_right (expr);
6642         tree start_tree;
6643         tree end_tree;
6644
6645         assert (ffebld_op (thing) == FFEBLD_opITEM);
6646         start = ffebld_head (thing);
6647         thing = ffebld_trail (thing);
6648         assert (ffebld_trail (thing) == NULL);
6649         end = ffebld_head (thing);
6650
6651         length = ffecom_intrinsic_len_ (ffebld_left (expr));
6652
6653         if (length == error_mark_node)
6654           break;
6655
6656         if (start == NULL)
6657           {
6658             if (end == NULL)
6659               ;
6660             else
6661               {
6662                 length = convert (ffecom_f2c_ftnlen_type_node,
6663                                   ffecom_expr (end));
6664               }
6665           }
6666         else
6667           {
6668             start_tree = convert (ffecom_f2c_ftnlen_type_node,
6669                                   ffecom_expr (start));
6670
6671             if (start_tree == error_mark_node)
6672               {
6673                 length = error_mark_node;
6674                 break;
6675               }
6676
6677             if (end == NULL)
6678               {
6679                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6680                                    ffecom_f2c_ftnlen_one_node,
6681                                    ffecom_2 (MINUS_EXPR,
6682                                              ffecom_f2c_ftnlen_type_node,
6683                                              length,
6684                                              start_tree));
6685               }
6686             else
6687               {
6688                 end_tree = convert (ffecom_f2c_ftnlen_type_node,
6689                                     ffecom_expr (end));
6690
6691                 if (end_tree == error_mark_node)
6692                   {
6693                     length = error_mark_node;
6694                     break;
6695                   }
6696
6697                 length = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6698                                    ffecom_f2c_ftnlen_one_node,
6699                                    ffecom_2 (MINUS_EXPR,
6700                                              ffecom_f2c_ftnlen_type_node,
6701                                              end_tree, start_tree));
6702               }
6703           }
6704       }
6705       break;
6706
6707     case FFEBLD_opCONCATENATE:
6708       length
6709         = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
6710                     ffecom_intrinsic_len_ (ffebld_left (expr)),
6711                     ffecom_intrinsic_len_ (ffebld_right (expr)));
6712       break;
6713
6714     case FFEBLD_opFUNCREF:
6715     case FFEBLD_opCONVERT:
6716       length = build_int_2 (ffebld_size (expr), 0);
6717       TREE_TYPE (length) = ffecom_f2c_ftnlen_type_node;
6718       break;
6719
6720     default:
6721       assert ("bad op for single char arg expr" == NULL);
6722       length = ffecom_f2c_ftnlen_zero_node;
6723       break;
6724     }
6725
6726   assert (length != NULL_TREE);
6727
6728   return length;
6729 }
6730
6731 #endif
6732 /* Handle CHARACTER assignments.
6733
6734    Generates code to do the assignment.  Used by ordinary assignment
6735    statement handler ffecom_let_stmt and by statement-function
6736    handler to generate code for a statement function.  */
6737
6738 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6739 static void
6740 ffecom_let_char_ (tree dest_tree, tree dest_length,
6741                   ffetargetCharacterSize dest_size, ffebld source)
6742 {
6743   ffecomConcatList_ catlist;
6744   tree source_length;
6745   tree source_tree;
6746   tree expr_tree;
6747
6748   if ((dest_tree == error_mark_node)
6749       || (dest_length == error_mark_node))
6750     return;
6751
6752   assert (dest_tree != NULL_TREE);
6753   assert (dest_length != NULL_TREE);
6754
6755   /* Source might be an opCONVERT, which just means it is a different size
6756      than the destination.  Since the underlying implementation here handles
6757      that (directly or via the s_copy or s_cat run-time-library functions),
6758      we don't need the "convenience" of an opCONVERT that tells us to
6759      truncate or blank-pad, particularly since the resulting implementation
6760      would probably be slower than otherwise. */
6761
6762   while (ffebld_op (source) == FFEBLD_opCONVERT)
6763     source = ffebld_left (source);
6764
6765   catlist = ffecom_concat_list_new_ (source, dest_size);
6766   switch (ffecom_concat_list_count_ (catlist))
6767     {
6768     case 0:                     /* Shouldn't happen, but in case it does... */
6769       ffecom_concat_list_kill_ (catlist);
6770       source_tree = null_pointer_node;
6771       source_length = ffecom_f2c_ftnlen_zero_node;
6772       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6773       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6774       TREE_CHAIN (TREE_CHAIN (expr_tree))
6775         = build_tree_list (NULL_TREE, dest_length);
6776       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6777         = build_tree_list (NULL_TREE, source_length);
6778
6779       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6780       TREE_SIDE_EFFECTS (expr_tree) = 1;
6781
6782       expand_expr_stmt (expr_tree);
6783
6784       return;
6785
6786     case 1:                     /* The (fairly) easy case. */
6787       ffecom_char_args_ (&source_tree, &source_length,
6788                          ffecom_concat_list_expr_ (catlist, 0));
6789       ffecom_concat_list_kill_ (catlist);
6790       assert (source_tree != NULL_TREE);
6791       assert (source_length != NULL_TREE);
6792
6793       if ((source_tree == error_mark_node)
6794           || (source_length == error_mark_node))
6795         return;
6796
6797       if (dest_size == 1)
6798         {
6799           dest_tree
6800             = ffecom_1 (INDIRECT_REF,
6801                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6802                                                       (dest_tree))),
6803                         dest_tree);
6804           dest_tree
6805             = ffecom_2 (ARRAY_REF,
6806                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6807                                                       (dest_tree))),
6808                         dest_tree,
6809                         integer_one_node);
6810           source_tree
6811             = ffecom_1 (INDIRECT_REF,
6812                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6813                                                       (source_tree))),
6814                         source_tree);
6815           source_tree
6816             = ffecom_2 (ARRAY_REF,
6817                         TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE
6818                                                       (source_tree))),
6819                         source_tree,
6820                         integer_one_node);
6821
6822           expr_tree = ffecom_modify (void_type_node, dest_tree, source_tree);
6823
6824           expand_expr_stmt (expr_tree);
6825
6826           return;
6827         }
6828
6829       expr_tree = build_tree_list (NULL_TREE, dest_tree);
6830       TREE_CHAIN (expr_tree) = build_tree_list (NULL_TREE, source_tree);
6831       TREE_CHAIN (TREE_CHAIN (expr_tree))
6832         = build_tree_list (NULL_TREE, dest_length);
6833       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6834         = build_tree_list (NULL_TREE, source_length);
6835
6836       expr_tree = ffecom_call_gfrt (FFECOM_gfrtCOPY, expr_tree, NULL_TREE);
6837       TREE_SIDE_EFFECTS (expr_tree) = 1;
6838
6839       expand_expr_stmt (expr_tree);
6840
6841       return;
6842
6843     default:                    /* Must actually concatenate things. */
6844       break;
6845     }
6846
6847   /* Heavy-duty concatenation. */
6848
6849   {
6850     int count = ffecom_concat_list_count_ (catlist);
6851     int i;
6852     tree lengths;
6853     tree items;
6854     tree length_array;
6855     tree item_array;
6856     tree citem;
6857     tree clength;
6858
6859 #ifdef HOHO
6860     length_array
6861       = lengths
6862       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
6863                              FFETARGET_charactersizeNONE, count, TRUE);
6864     item_array = items = ffecom_push_tempvar (ffecom_f2c_address_type_node,
6865                                               FFETARGET_charactersizeNONE,
6866                                               count, TRUE);
6867 #else
6868     {
6869       tree hook;
6870
6871       hook = ffebld_nonter_hook (source);
6872       assert (hook);
6873       assert (TREE_CODE (hook) == TREE_VEC);
6874       assert (TREE_VEC_LENGTH (hook) == 2);
6875       length_array = lengths = TREE_VEC_ELT (hook, 0);
6876       item_array = items = TREE_VEC_ELT (hook, 1);
6877     }
6878 #endif
6879
6880     for (i = 0; i < count; ++i)
6881       {
6882         ffecom_char_args_ (&citem, &clength,
6883                            ffecom_concat_list_expr_ (catlist, i));
6884         if ((citem == error_mark_node)
6885             || (clength == error_mark_node))
6886           {
6887             ffecom_concat_list_kill_ (catlist);
6888             return;
6889           }
6890
6891         items
6892           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
6893                       ffecom_modify (void_type_node,
6894                                      ffecom_2 (ARRAY_REF,
6895                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
6896                                                item_array,
6897                                                build_int_2 (i, 0)),
6898                                      citem),
6899                       items);
6900         lengths
6901           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
6902                       ffecom_modify (void_type_node,
6903                                      ffecom_2 (ARRAY_REF,
6904                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
6905                                                length_array,
6906                                                build_int_2 (i, 0)),
6907                                      clength),
6908                       lengths);
6909       }
6910
6911     expr_tree = build_tree_list (NULL_TREE, dest_tree);
6912     TREE_CHAIN (expr_tree)
6913       = build_tree_list (NULL_TREE,
6914                          ffecom_1 (ADDR_EXPR,
6915                                    build_pointer_type (TREE_TYPE (items)),
6916                                    items));
6917     TREE_CHAIN (TREE_CHAIN (expr_tree))
6918       = build_tree_list (NULL_TREE,
6919                          ffecom_1 (ADDR_EXPR,
6920                                    build_pointer_type (TREE_TYPE (lengths)),
6921                                    lengths));
6922     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree)))
6923       = build_tree_list
6924         (NULL_TREE,
6925          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
6926                    convert (ffecom_f2c_ftnlen_type_node,
6927                             build_int_2 (count, 0))));
6928     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (expr_tree))))
6929       = build_tree_list (NULL_TREE, dest_length);
6930
6931     expr_tree = ffecom_call_gfrt (FFECOM_gfrtCAT, expr_tree, NULL_TREE);
6932     TREE_SIDE_EFFECTS (expr_tree) = 1;
6933
6934     expand_expr_stmt (expr_tree);
6935   }
6936
6937   ffecom_concat_list_kill_ (catlist);
6938 }
6939
6940 #endif
6941 /* ffecom_make_gfrt_ -- Make initial info for run-time routine
6942
6943    ffecomGfrt ix;
6944    ffecom_make_gfrt_(ix);
6945
6946    Assumes gfrt_[ix] is NULL_TREE, and replaces it with the FUNCTION_DECL
6947    for the indicated run-time routine (ix).  */
6948
6949 #if FFECOM_targetCURRENT == FFECOM_targetGCC
6950 static void
6951 ffecom_make_gfrt_ (ffecomGfrt ix)
6952 {
6953   tree t;
6954   tree ttype;
6955
6956   switch (ffecom_gfrt_type_[ix])
6957     {
6958     case FFECOM_rttypeVOID_:
6959       ttype = void_type_node;
6960       break;
6961
6962     case FFECOM_rttypeVOIDSTAR_:
6963       ttype = TREE_TYPE (null_pointer_node);    /* `void *'. */
6964       break;
6965
6966     case FFECOM_rttypeFTNINT_:
6967       ttype = ffecom_f2c_ftnint_type_node;
6968       break;
6969
6970     case FFECOM_rttypeINTEGER_:
6971       ttype = ffecom_f2c_integer_type_node;
6972       break;
6973
6974     case FFECOM_rttypeLONGINT_:
6975       ttype = ffecom_f2c_longint_type_node;
6976       break;
6977
6978     case FFECOM_rttypeLOGICAL_:
6979       ttype = ffecom_f2c_logical_type_node;
6980       break;
6981
6982     case FFECOM_rttypeREAL_F2C_:
6983       ttype = double_type_node;
6984       break;
6985
6986     case FFECOM_rttypeREAL_GNU_:
6987       ttype = float_type_node;
6988       break;
6989
6990     case FFECOM_rttypeCOMPLEX_F2C_:
6991       ttype = void_type_node;
6992       break;
6993
6994     case FFECOM_rttypeCOMPLEX_GNU_:
6995       ttype = ffecom_f2c_complex_type_node;
6996       break;
6997
6998     case FFECOM_rttypeDOUBLE_:
6999       ttype = double_type_node;
7000       break;
7001
7002     case FFECOM_rttypeDOUBLEREAL_:
7003       ttype = ffecom_f2c_doublereal_type_node;
7004       break;
7005
7006     case FFECOM_rttypeDBLCMPLX_F2C_:
7007       ttype = void_type_node;
7008       break;
7009
7010     case FFECOM_rttypeDBLCMPLX_GNU_:
7011       ttype = ffecom_f2c_doublecomplex_type_node;
7012       break;
7013
7014     case FFECOM_rttypeCHARACTER_:
7015       ttype = void_type_node;
7016       break;
7017
7018     default:
7019       ttype = NULL;
7020       assert ("bad rttype" == NULL);
7021       break;
7022     }
7023
7024   ttype = build_function_type (ttype, NULL_TREE);
7025   t = build_decl (FUNCTION_DECL,
7026                   get_identifier (ffecom_gfrt_name_[ix]),
7027                   ttype);
7028   DECL_EXTERNAL (t) = 1;
7029   TREE_READONLY (t) = ffecom_gfrt_const_[ix] ? 1 : 0;
7030   TREE_PUBLIC (t) = 1;
7031   TREE_THIS_VOLATILE (t) = ffecom_gfrt_volatile_[ix] ? 1 : 0;
7032
7033   /* Sanity check:  A function that's const cannot be volatile.  */
7034
7035   assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_volatile_[ix] : 1);
7036
7037   /* Sanity check: A function that's const cannot return complex.  */
7038
7039   assert (ffecom_gfrt_const_[ix] ? !ffecom_gfrt_complex_[ix] : 1);
7040
7041   t = start_decl (t, TRUE);
7042
7043   finish_decl (t, NULL_TREE, TRUE);
7044
7045   ffecom_gfrt_[ix] = t;
7046 }
7047
7048 #endif
7049 /* Phase 1 pass over each member of a COMMON/EQUIVALENCE group.  */
7050
7051 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7052 static void
7053 ffecom_member_phase1_ (ffestorag mst UNUSED, ffestorag st)
7054 {
7055   ffesymbol s = ffestorag_symbol (st);
7056
7057   if (ffesymbol_namelisted (s))
7058     ffecom_member_namelisted_ = TRUE;
7059 }
7060
7061 #endif
7062 /* Phase 2 pass over each member of a COMMON/EQUIVALENCE group.  Declare
7063    the member so debugger will see it.  Otherwise nobody should be
7064    referencing the member.  */
7065
7066 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7067 static void
7068 ffecom_member_phase2_ (ffestorag mst, ffestorag st)
7069 {
7070   ffesymbol s;
7071   tree t;
7072   tree mt;
7073   tree type;
7074
7075   if ((mst == NULL)
7076       || ((mt = ffestorag_hook (mst)) == NULL)
7077       || (mt == error_mark_node))
7078     return;
7079
7080   if ((st == NULL)
7081       || ((s = ffestorag_symbol (st)) == NULL))
7082     return;
7083
7084   type = ffecom_type_localvar_ (s,
7085                                 ffesymbol_basictype (s),
7086                                 ffesymbol_kindtype (s));
7087   if (type == error_mark_node)
7088     return;
7089
7090   t = build_decl (VAR_DECL,
7091                   ffecom_get_identifier_ (ffesymbol_text (s)),
7092                   type);
7093
7094   TREE_STATIC (t) = TREE_STATIC (mt);
7095   DECL_INITIAL (t) = NULL_TREE;
7096   TREE_ASM_WRITTEN (t) = 1;
7097   TREE_USED (t) = 1;
7098
7099   DECL_RTL (t)
7100     = gen_rtx (MEM, TYPE_MODE (type),
7101                plus_constant (XEXP (DECL_RTL (mt), 0),
7102                               ffestorag_modulo (mst)
7103                               + ffestorag_offset (st)
7104                               - ffestorag_offset (mst)));
7105
7106   t = start_decl (t, FALSE);
7107
7108   finish_decl (t, NULL_TREE, FALSE);
7109 }
7110
7111 #endif
7112 /* Prepare source expression for assignment into a destination perhaps known
7113    to be of a specific size.  */
7114
7115 static void
7116 ffecom_prepare_let_char_ (ffetargetCharacterSize dest_size, ffebld source)
7117 {
7118   ffecomConcatList_ catlist;
7119   int count;
7120   int i;
7121   tree ltmp;
7122   tree itmp;
7123   tree tempvar = NULL_TREE;
7124
7125   while (ffebld_op (source) == FFEBLD_opCONVERT)
7126     source = ffebld_left (source);
7127
7128   catlist = ffecom_concat_list_new_ (source, dest_size);
7129   count = ffecom_concat_list_count_ (catlist);
7130
7131   if (count >= 2)
7132     {
7133       ltmp
7134         = ffecom_make_tempvar ("let_char_len", ffecom_f2c_ftnlen_type_node,
7135                                FFETARGET_charactersizeNONE, count);
7136       itmp
7137         = ffecom_make_tempvar ("let_char_item", ffecom_f2c_address_type_node,
7138                                FFETARGET_charactersizeNONE, count);
7139
7140       tempvar = make_tree_vec (2);
7141       TREE_VEC_ELT (tempvar, 0) = ltmp;
7142       TREE_VEC_ELT (tempvar, 1) = itmp;
7143     }
7144
7145   for (i = 0; i < count; ++i)
7146     ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist, i));
7147
7148   ffecom_concat_list_kill_ (catlist);
7149
7150   if (tempvar)
7151     {
7152       ffebld_nonter_set_hook (source, tempvar);
7153       current_binding_level->prep_state = 1;
7154     }
7155 }
7156
7157 /* ffecom_push_dummy_decls_ -- Transform dummy args, push parm decls in order
7158
7159    Ignores STAR (alternate-return) dummies.  All other get exec-transitioned
7160    (which generates their trees) and then their trees get push_parm_decl'd.
7161
7162    The second arg is TRUE if the dummies are for a statement function, in
7163    which case lengths are not pushed for character arguments (since they are
7164    always known by both the caller and the callee, though the code allows
7165    for someday permitting CHAR*(*) stmtfunc dummies).  */
7166
7167 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7168 static void
7169 ffecom_push_dummy_decls_ (ffebld dummy_list, bool stmtfunc)
7170 {
7171   ffebld dummy;
7172   ffebld dumlist;
7173   ffesymbol s;
7174   tree parm;
7175
7176   ffecom_transform_only_dummies_ = TRUE;
7177
7178   /* First push the parms corresponding to actual dummy "contents".  */
7179
7180   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7181     {
7182       dummy = ffebld_head (dumlist);
7183       switch (ffebld_op (dummy))
7184         {
7185         case FFEBLD_opSTAR:
7186         case FFEBLD_opANY:
7187           continue;             /* Forget alternate returns. */
7188
7189         default:
7190           break;
7191         }
7192       assert (ffebld_op (dummy) == FFEBLD_opSYMTER);
7193       s = ffebld_symter (dummy);
7194       parm = ffesymbol_hook (s).decl_tree;
7195       if (parm == NULL_TREE)
7196         {
7197           s = ffecom_sym_transform_ (s);
7198           parm = ffesymbol_hook (s).decl_tree;
7199           assert (parm != NULL_TREE);
7200         }
7201       if (parm != error_mark_node)
7202         push_parm_decl (parm);
7203     }
7204
7205   /* Then, for CHARACTER dummies, push the parms giving their lengths.  */
7206
7207   for (dumlist = dummy_list; dumlist != NULL; dumlist = ffebld_trail (dumlist))
7208     {
7209       dummy = ffebld_head (dumlist);
7210       switch (ffebld_op (dummy))
7211         {
7212         case FFEBLD_opSTAR:
7213         case FFEBLD_opANY:
7214           continue;             /* Forget alternate returns, they mean
7215                                    NOTHING! */
7216
7217         default:
7218           break;
7219         }
7220       s = ffebld_symter (dummy);
7221       if (ffesymbol_basictype (s) != FFEINFO_basictypeCHARACTER)
7222         continue;               /* Only looking for CHARACTER arguments. */
7223       if (stmtfunc && (ffesymbol_size (s) != FFETARGET_charactersizeNONE))
7224         continue;               /* Stmtfunc arg with known size needs no
7225                                    length param. */
7226       if (ffesymbol_kind (s) != FFEINFO_kindENTITY)
7227         continue;               /* Only looking for variables and arrays. */
7228       parm = ffesymbol_hook (s).length_tree;
7229       assert (parm != NULL_TREE);
7230       if (parm != error_mark_node)
7231         push_parm_decl (parm);
7232     }
7233
7234   ffecom_transform_only_dummies_ = FALSE;
7235 }
7236
7237 #endif
7238 /* ffecom_start_progunit_ -- Beginning of program unit
7239
7240    Does GNU back end stuff necessary to teach it about the start of its
7241    equivalent of a Fortran program unit.  */
7242
7243 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7244 static void
7245 ffecom_start_progunit_ ()
7246 {
7247   ffesymbol fn = ffecom_primary_entry_;
7248   ffebld arglist;
7249   tree id;                      /* Identifier (name) of function. */
7250   tree type;                    /* Type of function. */
7251   tree result;                  /* Result of function. */
7252   ffeinfoBasictype bt;
7253   ffeinfoKindtype kt;
7254   ffeglobal g;
7255   ffeglobalType gt;
7256   ffeglobalType egt = FFEGLOBAL_type;
7257   bool charfunc;
7258   bool cmplxfunc;
7259   bool altentries = (ffecom_num_entrypoints_ != 0);
7260   bool multi
7261   = altentries
7262   && (ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
7263   && (ffecom_master_bt_ == FFEINFO_basictypeNONE);
7264   bool main_program = FALSE;
7265   int old_lineno = lineno;
7266   const char *old_input_filename = input_filename;
7267
7268   assert (fn != NULL);
7269   assert (ffesymbol_hook (fn).decl_tree == NULL_TREE);
7270
7271   input_filename = ffesymbol_where_filename (fn);
7272   lineno = ffesymbol_where_filelinenum (fn);
7273
7274   switch (ffecom_primary_entry_kind_)
7275     {
7276     case FFEINFO_kindPROGRAM:
7277       main_program = TRUE;
7278       gt = FFEGLOBAL_typeMAIN;
7279       bt = FFEINFO_basictypeNONE;
7280       kt = FFEINFO_kindtypeNONE;
7281       type = ffecom_tree_fun_type_void;
7282       charfunc = FALSE;
7283       cmplxfunc = FALSE;
7284       break;
7285
7286     case FFEINFO_kindBLOCKDATA:
7287       gt = FFEGLOBAL_typeBDATA;
7288       bt = FFEINFO_basictypeNONE;
7289       kt = FFEINFO_kindtypeNONE;
7290       type = ffecom_tree_fun_type_void;
7291       charfunc = FALSE;
7292       cmplxfunc = FALSE;
7293       break;
7294
7295     case FFEINFO_kindFUNCTION:
7296       gt = FFEGLOBAL_typeFUNC;
7297       egt = FFEGLOBAL_typeEXT;
7298       bt = ffesymbol_basictype (fn);
7299       kt = ffesymbol_kindtype (fn);
7300       if (bt == FFEINFO_basictypeNONE)
7301         {
7302           ffeimplic_establish_symbol (fn);
7303           if (ffesymbol_funcresult (fn) != NULL)
7304             ffeimplic_establish_symbol (ffesymbol_funcresult (fn));
7305           bt = ffesymbol_basictype (fn);
7306           kt = ffesymbol_kindtype (fn);
7307         }
7308
7309       if (multi)
7310         charfunc = cmplxfunc = FALSE;
7311       else if (bt == FFEINFO_basictypeCHARACTER)
7312         charfunc = TRUE, cmplxfunc = FALSE;
7313       else if ((bt == FFEINFO_basictypeCOMPLEX)
7314                && ffesymbol_is_f2c (fn)
7315                && !altentries)
7316         charfunc = FALSE, cmplxfunc = TRUE;
7317       else
7318         charfunc = cmplxfunc = FALSE;
7319
7320       if (multi || charfunc)
7321         type = ffecom_tree_fun_type_void;
7322       else if (ffesymbol_is_f2c (fn) && !altentries)
7323         type = ffecom_tree_fun_type[bt][kt];
7324       else
7325         type = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
7326
7327       if ((type == NULL_TREE)
7328           || (TREE_TYPE (type) == NULL_TREE))
7329         type = ffecom_tree_fun_type_void;       /* _sym_exec_transition. */
7330       break;
7331
7332     case FFEINFO_kindSUBROUTINE:
7333       gt = FFEGLOBAL_typeSUBR;
7334       egt = FFEGLOBAL_typeEXT;
7335       bt = FFEINFO_basictypeNONE;
7336       kt = FFEINFO_kindtypeNONE;
7337       if (ffecom_is_altreturning_)
7338         type = ffecom_tree_subr_type;
7339       else
7340         type = ffecom_tree_fun_type_void;
7341       charfunc = FALSE;
7342       cmplxfunc = FALSE;
7343       break;
7344
7345     default:
7346       assert ("say what??" == NULL);
7347       /* Fall through. */
7348     case FFEINFO_kindANY:
7349       gt = FFEGLOBAL_typeANY;
7350       bt = FFEINFO_basictypeNONE;
7351       kt = FFEINFO_kindtypeNONE;
7352       type = error_mark_node;
7353       charfunc = FALSE;
7354       cmplxfunc = FALSE;
7355       break;
7356     }
7357
7358   if (altentries)
7359     {
7360       id = ffecom_get_invented_identifier ("__g77_masterfun_%s",
7361                                            ffesymbol_text (fn));
7362     }
7363 #if FFETARGET_isENFORCED_MAIN
7364   else if (main_program)
7365     id = get_identifier (FFETARGET_nameENFORCED_MAIN_NAME);
7366 #endif
7367   else
7368     id = ffecom_get_external_identifier_ (fn);
7369
7370   start_function (id,
7371                   type,
7372                   0,            /* nested/inline */
7373                   !altentries); /* TREE_PUBLIC */
7374
7375   TREE_USED (current_function_decl) = 1;        /* Avoid spurious warning if altentries. */
7376
7377   if (!altentries
7378       && ((g = ffesymbol_global (fn)) != NULL)
7379       && ((ffeglobal_type (g) == gt)
7380           || (ffeglobal_type (g) == egt)))
7381     {
7382       ffeglobal_set_hook (g, current_function_decl);
7383     }
7384
7385   /* Arg handling needs exec-transitioned ffesymbols to work with.  But
7386      exec-transitioning needs current_function_decl to be filled in.  So we
7387      do these things in two phases. */
7388
7389   if (altentries)
7390     {                           /* 1st arg identifies which entrypoint. */
7391       ffecom_which_entrypoint_decl_
7392         = build_decl (PARM_DECL,
7393                       ffecom_get_invented_identifier ("__g77_%s",
7394                                                       "which_entrypoint"),
7395                       integer_type_node);
7396       push_parm_decl (ffecom_which_entrypoint_decl_);
7397     }
7398
7399   if (charfunc
7400       || cmplxfunc
7401       || multi)
7402     {                           /* Arg for result (return value). */
7403       tree type;
7404       tree length;
7405
7406       if (charfunc)
7407         type = ffecom_tree_type[FFEINFO_basictypeCHARACTER][kt];
7408       else if (cmplxfunc)
7409         type = ffecom_tree_type[FFEINFO_basictypeCOMPLEX][kt];
7410       else
7411         type = ffecom_multi_type_node_;
7412
7413       result = ffecom_get_invented_identifier ("__g77_%s", "result");
7414
7415       /* Make length arg _and_ enhance type info for CHAR arg itself.  */
7416
7417       if (charfunc)
7418         length = ffecom_char_enhance_arg_ (&type, fn);
7419       else
7420         length = NULL_TREE;     /* Not ref'd if !charfunc. */
7421
7422       type = build_pointer_type (type);
7423       result = build_decl (PARM_DECL, result, type);
7424
7425       push_parm_decl (result);
7426       if (multi)
7427         ffecom_multi_retval_ = result;
7428       else
7429         ffecom_func_result_ = result;
7430
7431       if (charfunc)
7432         {
7433           push_parm_decl (length);
7434           ffecom_func_length_ = length;
7435         }
7436     }
7437
7438   if (ffecom_primary_entry_is_proc_)
7439     {
7440       if (altentries)
7441         arglist = ffecom_master_arglist_;
7442       else
7443         arglist = ffesymbol_dummyargs (fn);
7444       ffecom_push_dummy_decls_ (arglist, FALSE);
7445     }
7446
7447   if (TREE_CODE (current_function_decl) != ERROR_MARK)
7448     store_parm_decls (main_program ? 1 : 0);
7449
7450   ffecom_start_compstmt ();
7451   /* Disallow temp vars at this level.  */
7452   current_binding_level->prep_state = 2;
7453
7454   lineno = old_lineno;
7455   input_filename = old_input_filename;
7456
7457   /* This handles any symbols still untransformed, in case -g specified.
7458      This used to be done in ffecom_finish_progunit, but it turns out to
7459      be necessary to do it here so that statement functions are
7460      expanded before code.  But don't bother for BLOCK DATA.  */
7461
7462   if (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
7463     ffesymbol_drive (ffecom_finish_symbol_transform_);
7464 }
7465
7466 #endif
7467 /* ffecom_sym_transform_ -- Transform FFE sym into backend sym
7468
7469    ffesymbol s;
7470    ffecom_sym_transform_(s);
7471
7472    The ffesymbol_hook info for s is updated with appropriate backend info
7473    on the symbol.  */
7474
7475 #if FFECOM_targetCURRENT == FFECOM_targetGCC
7476 static ffesymbol
7477 ffecom_sym_transform_ (ffesymbol s)
7478 {
7479   tree t;                       /* Transformed thingy. */
7480   tree tlen;                    /* Length if CHAR*(*). */
7481   bool addr;                    /* Is t the address of the thingy? */
7482   ffeinfoBasictype bt;
7483   ffeinfoKindtype kt;
7484   ffeglobal g;
7485   int old_lineno = lineno;
7486   const char *old_input_filename = input_filename;
7487
7488   /* Must ensure special ASSIGN variables are declared at top of outermost
7489      block, else they'll end up in the innermost block when their first
7490      ASSIGN is seen, which leaves them out of scope when they're the
7491      subject of a GOTO or I/O statement.
7492
7493      We make this variable even if -fugly-assign.  Just let it go unused,
7494      in case it turns out there are cases where we really want to use this
7495      variable anyway (e.g. ASSIGN to INTEGER*2 variable).  */
7496
7497   if (! ffecom_transform_only_dummies_
7498       && ffesymbol_assigned (s)
7499       && ! ffesymbol_hook (s).assign_tree)
7500     s = ffecom_sym_transform_assign_ (s);
7501
7502   if (ffesymbol_sfdummyparent (s) == NULL)
7503     {
7504       input_filename = ffesymbol_where_filename (s);
7505       lineno = ffesymbol_where_filelinenum (s);
7506     }
7507   else
7508     {
7509       ffesymbol sf = ffesymbol_sfdummyparent (s);
7510
7511       input_filename = ffesymbol_where_filename (sf);
7512       lineno = ffesymbol_where_filelinenum (sf);
7513     }
7514
7515   bt = ffeinfo_basictype (ffebld_info (s));
7516   kt = ffeinfo_kindtype (ffebld_info (s));
7517
7518   t = NULL_TREE;
7519   tlen = NULL_TREE;
7520   addr = FALSE;
7521
7522   switch (ffesymbol_kind (s))
7523     {
7524     case FFEINFO_kindNONE:
7525       switch (ffesymbol_where (s))
7526         {
7527         case FFEINFO_whereDUMMY:        /* Subroutine or function. */
7528           assert (ffecom_transform_only_dummies_);
7529
7530           /* Before 0.4, this could be ENTITY/DUMMY, but see
7531              ffestu_sym_end_transition -- no longer true (in particular, if
7532              it could be an ENTITY, it _will_ be made one, so that
7533              possibility won't come through here).  So we never make length
7534              arg for CHARACTER type.  */
7535
7536           t = build_decl (PARM_DECL,
7537                           ffecom_get_identifier_ (ffesymbol_text (s)),
7538                           ffecom_tree_ptr_to_subr_type);
7539 #if BUILT_FOR_270
7540           DECL_ARTIFICIAL (t) = 1;
7541 #endif
7542           addr = TRUE;
7543           break;
7544
7545         case FFEINFO_whereGLOBAL:       /* Subroutine or function. */
7546           assert (!ffecom_transform_only_dummies_);
7547
7548           if (((g = ffesymbol_global (s)) != NULL)
7549               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7550                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7551                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
7552               && (ffeglobal_hook (g) != NULL_TREE)
7553               && ffe_is_globals ())
7554             {
7555               t = ffeglobal_hook (g);
7556               break;
7557             }
7558
7559           t = build_decl (FUNCTION_DECL,
7560                           ffecom_get_external_identifier_ (s),
7561                           ffecom_tree_subr_type);       /* Assume subr. */
7562           DECL_EXTERNAL (t) = 1;
7563           TREE_PUBLIC (t) = 1;
7564
7565           t = start_decl (t, FALSE);
7566           finish_decl (t, NULL_TREE, FALSE);
7567
7568           if ((g != NULL)
7569               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
7570                   || (ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
7571                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
7572             ffeglobal_set_hook (g, t);
7573
7574           ffecom_save_tree_forever (t);
7575
7576           break;
7577
7578         default:
7579           assert ("NONE where unexpected" == NULL);
7580           /* Fall through. */
7581         case FFEINFO_whereANY:
7582           break;
7583         }
7584       break;
7585
7586     case FFEINFO_kindENTITY:
7587       switch (ffeinfo_where (ffesymbol_info (s)))
7588         {
7589
7590         case FFEINFO_whereCONSTANT:
7591           /* ~~Debugging info needed? */
7592           assert (!ffecom_transform_only_dummies_);
7593           t = error_mark_node;  /* Shouldn't ever see this in expr. */
7594           break;
7595
7596         case FFEINFO_whereLOCAL:
7597           assert (!ffecom_transform_only_dummies_);
7598
7599           {
7600             ffestorag st = ffesymbol_storage (s);
7601             tree type;
7602
7603             if ((st != NULL)
7604                 && (ffestorag_size (st) == 0))
7605               {
7606                 t = error_mark_node;
7607                 break;
7608               }
7609
7610             type = ffecom_type_localvar_ (s, bt, kt);
7611
7612             if (type == error_mark_node)
7613               {
7614                 t = error_mark_node;
7615                 break;
7616               }
7617
7618             if ((st != NULL)
7619                 && (ffestorag_parent (st) != NULL))
7620               {                 /* Child of EQUIVALENCE parent. */
7621                 ffestorag est;
7622                 tree et;
7623                 ffetargetOffset offset;
7624
7625                 est = ffestorag_parent (st);
7626                 ffecom_transform_equiv_ (est);
7627
7628                 et = ffestorag_hook (est);
7629                 assert (et != NULL_TREE);
7630
7631                 if (! TREE_STATIC (et))
7632                   put_var_into_stack (et);
7633
7634                 offset = ffestorag_modulo (est)
7635                   + ffestorag_offset (ffesymbol_storage (s))
7636                   - ffestorag_offset (est);
7637
7638                 ffecom_debug_kludge_ (et, "EQUIVALENCE", s, type, offset);
7639
7640                 /* (t_type *) (((char *) &et) + offset) */
7641
7642                 t = convert (string_type_node,  /* (char *) */
7643                              ffecom_1 (ADDR_EXPR,
7644                                        build_pointer_type (TREE_TYPE (et)),
7645                                        et));
7646                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
7647                               t,
7648                               build_int_2 (offset, 0));
7649                 t = convert (build_pointer_type (type),
7650                              t);
7651                 TREE_CONSTANT (t) = staticp (et);
7652
7653                 addr = TRUE;
7654               }
7655             else
7656               {
7657                 tree initexpr;
7658                 bool init = ffesymbol_is_init (s);
7659
7660                 t = build_decl (VAR_DECL,
7661                                 ffecom_get_identifier_ (ffesymbol_text (s)),
7662                                 type);
7663
7664                 if (init
7665                     || ffesymbol_namelisted (s)
7666 #ifdef FFECOM_sizeMAXSTACKITEM
7667                     || ((st != NULL)
7668                         && (ffestorag_size (st) > FFECOM_sizeMAXSTACKITEM))
7669 #endif
7670                     || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
7671                         && (ffecom_primary_entry_kind_
7672                             != FFEINFO_kindBLOCKDATA)
7673                         && (ffesymbol_is_save (s) || ffe_is_saveall ())))
7674                   TREE_STATIC (t) = !ffesymbol_attr (s, FFESYMBOL_attrADJUSTABLE);
7675                 else
7676                   TREE_STATIC (t) = 0;  /* No need to make static. */
7677
7678                 if (init || ffe_is_init_local_zero ())
7679                   DECL_INITIAL (t) = error_mark_node;
7680
7681                 /* Keep -Wunused from complaining about var if it
7682                    is used as sfunc arg or DATA implied-DO.  */
7683                 if (ffesymbol_attrs (s) & FFESYMBOL_attrsSFARG)
7684                   DECL_IN_SYSTEM_HEADER (t) = 1;
7685
7686                 t = start_decl (t, FALSE);
7687
7688                 if (init)
7689                   {
7690                     if (ffesymbol_init (s) != NULL)
7691                       initexpr = ffecom_expr (ffesymbol_init (s));
7692                     else
7693                       initexpr = ffecom_init_zero_ (t);
7694                   }
7695                 else if (ffe_is_init_local_zero ())
7696                   initexpr = ffecom_init_zero_ (t);
7697                 else
7698                   initexpr = NULL_TREE; /* Not ref'd if !init. */
7699
7700                 finish_decl (t, initexpr, FALSE);
7701
7702                 if (st != NULL && DECL_SIZE (t) != error_mark_node)
7703                   {
7704                     assert (TREE_CODE (DECL_SIZE_UNIT (t)) == INTEGER_CST);
7705                     assert (0 == compare_tree_int (DECL_SIZE_UNIT (t),
7706                                                    ffestorag_size (st)));
7707                   }
7708               }
7709           }
7710           break;
7711
7712         case FFEINFO_whereRESULT:
7713           assert (!ffecom_transform_only_dummies_);
7714
7715           if (bt == FFEINFO_basictypeCHARACTER)
7716             {                   /* Result is already in list of dummies, use
7717                                    it (& length). */
7718               t = ffecom_func_result_;
7719               tlen = ffecom_func_length_;
7720               addr = TRUE;
7721               break;
7722             }
7723           if ((ffecom_num_entrypoints_ == 0)
7724               && (bt == FFEINFO_basictypeCOMPLEX)
7725               && (ffesymbol_is_f2c (ffecom_primary_entry_)))
7726             {                   /* Result is already in list of dummies, use
7727                                    it. */
7728               t = ffecom_func_result_;
7729               addr = TRUE;
7730               break;
7731             }
7732           if (ffecom_func_result_ != NULL_TREE)
7733             {
7734               t = ffecom_func_result_;
7735               break;
7736             }
7737           if ((ffecom_num_entrypoints_ != 0)
7738               && (ffecom_master_bt_ == FFEINFO_basictypeNONE))
7739             {
7740               assert (ffecom_multi_retval_ != NULL_TREE);
7741               t = ffecom_1 (INDIRECT_REF, ffecom_multi_type_node_,
7742                             ffecom_multi_retval_);
7743               t = ffecom_2 (COMPONENT_REF, ffecom_tree_type[bt][kt],
7744                             t, ffecom_multi_fields_[bt][kt]);
7745
7746               break;
7747             }
7748
7749           t = build_decl (VAR_DECL,
7750                           ffecom_get_identifier_ (ffesymbol_text (s)),
7751                           ffecom_tree_type[bt][kt]);
7752           TREE_STATIC (t) = 0;  /* Put result on stack. */
7753           t = start_decl (t, FALSE);
7754           finish_decl (t, NULL_TREE, FALSE);
7755
7756           ffecom_func_result_ = t;
7757
7758           break;
7759
7760         case FFEINFO_whereDUMMY:
7761           {
7762             tree type;
7763             ffebld dl;
7764             ffebld dim;
7765             tree low;
7766             tree high;
7767             tree old_sizes;
7768             bool adjustable = FALSE;    /* Conditionally adjustable? */
7769
7770             type = ffecom_tree_type[bt][kt];
7771             if (ffesymbol_sfdummyparent (s) != NULL)
7772               {
7773                 if (current_function_decl == ffecom_outer_function_decl_)
7774                   {                     /* Exec transition before sfunc
7775                                            context; get it later. */
7776                     break;
7777                   }
7778                 t = ffecom_get_identifier_ (ffesymbol_text
7779                                             (ffesymbol_sfdummyparent (s)));
7780               }
7781             else
7782               t = ffecom_get_identifier_ (ffesymbol_text (s));
7783
7784             assert (ffecom_transform_only_dummies_);
7785
7786             old_sizes = get_pending_sizes ();
7787             put_pending_sizes (old_sizes);
7788
7789             if (bt == FFEINFO_basictypeCHARACTER)
7790               tlen = ffecom_char_enhance_arg_ (&type, s);
7791             type = ffecom_check_size_overflow_ (s, type, TRUE);
7792
7793             for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
7794               {
7795                 if (type == error_mark_node)
7796                   break;
7797
7798                 dim = ffebld_head (dl);
7799                 assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
7800                 if ((ffebld_left (dim) == NULL) || ffecom_doing_entry_)
7801                   low = ffecom_integer_one_node;
7802                 else
7803                   low = ffecom_expr (ffebld_left (dim));
7804                 assert (ffebld_right (dim) != NULL);
7805                 if ((ffebld_op (ffebld_right (dim)) == FFEBLD_opSTAR)
7806                     || ffecom_doing_entry_)
7807                   {
7808                     /* Used to just do high=low.  But for ffecom_tree_
7809                        canonize_ref_, it probably is important to correctly
7810                        assess the size.  E.g. given COMPLEX C(*),CFUNC and
7811                        C(2)=CFUNC(C), overlap can happen, while it can't
7812                        for, say, C(1)=CFUNC(C(2)).  */
7813                     /* Even more recently used to set to INT_MAX, but that
7814                        broke when some overflow checking went into the back
7815                        end.  Now we just leave the upper bound unspecified.  */
7816                     high = NULL;
7817                   }
7818                 else
7819                   high = ffecom_expr (ffebld_right (dim));
7820
7821                 /* Determine whether array is conditionally adjustable,
7822                    to decide whether back-end magic is needed.
7823
7824                    Normally the front end uses the back-end function
7825                    variable_size to wrap SAVE_EXPR's around expressions
7826                    affecting the size/shape of an array so that the
7827                    size/shape info doesn't change during execution
7828                    of the compiled code even though variables and
7829                    functions referenced in those expressions might.
7830
7831                    variable_size also makes sure those saved expressions
7832                    get evaluated immediately upon entry to the
7833                    compiled procedure -- the front end normally doesn't
7834                    have to worry about that.
7835
7836                    However, there is a problem with this that affects
7837                    g77's implementation of entry points, and that is
7838                    that it is _not_ true that each invocation of the
7839                    compiled procedure is permitted to evaluate
7840                    array size/shape info -- because it is possible
7841                    that, for some invocations, that info is invalid (in
7842                    which case it is "promised" -- i.e. a violation of
7843                    the Fortran standard -- that the compiled code
7844                    won't reference the array or its size/shape
7845                    during that particular invocation).
7846
7847                    To phrase this in C terms, consider this gcc function:
7848
7849                      void foo (int *n, float (*a)[*n])
7850                      {
7851                        // a is "pointer to array ...", fyi.
7852                      }
7853
7854                    Suppose that, for some invocations, it is permitted
7855                    for a caller of foo to do this:
7856
7857                        foo (NULL, NULL);
7858
7859                    Now the _written_ code for foo can take such a call
7860                    into account by either testing explicitly for whether
7861                    (a == NULL) || (n == NULL) -- presumably it is
7862                    not permitted to reference *a in various fashions
7863                    if (n == NULL) I suppose -- or it can avoid it by
7864                    looking at other info (other arguments, static/global
7865                    data, etc.).
7866
7867                    However, this won't work in gcc 2.5.8 because it'll
7868                    automatically emit the code to save the "*n"
7869                    expression, which'll yield a NULL dereference for
7870                    the "foo (NULL, NULL)" call, something the code
7871                    for foo cannot prevent.
7872
7873                    g77 definitely needs to avoid executing such
7874                    code anytime the pointer to the adjustable array
7875                    is NULL, because even if its bounds expressions
7876                    don't have any references to possible "absent"
7877                    variables like "*n" -- say all variable references
7878                    are to COMMON variables, i.e. global (though in C,
7879                    local static could actually make sense) -- the
7880                    expressions could yield other run-time problems
7881                    for allowably "dead" values in those variables.
7882
7883                    For example, let's consider a more complicated
7884                    version of foo:
7885
7886                      extern int i;
7887                      extern int j;
7888
7889                      void foo (float (*a)[i/j])
7890                      {
7891                        ...
7892                      }
7893
7894                    The above is (essentially) quite valid for Fortran
7895                    but, again, for a call like "foo (NULL);", it is
7896                    permitted for i and j to be undefined when the
7897                    call is made.  If j happened to be zero, for
7898                    example, emitting the code to evaluate "i/j"
7899                    could result in a run-time error.
7900
7901                    Offhand, though I don't have my F77 or F90
7902                    standards handy, it might even be valid for a
7903                    bounds expression to contain a function reference,
7904                    in which case I doubt it is permitted for an
7905                    implementation to invoke that function in the
7906                    Fortran case involved here (invocation of an
7907                    alternate ENTRY point that doesn't have the adjustable
7908                    array as one of its arguments).
7909
7910                    So, the code that the compiler would normally emit
7911                    to preevaluate the size/shape info for an
7912                    adjustable array _must not_ be executed at run time
7913                    in certain cases.  Specifically, for Fortran,
7914                    the case is when the pointer to the adjustable
7915                    array == NULL.  (For gnu-ish C, it might be nice
7916                    for the source code itself to specify an expression
7917                    that, if TRUE, inhibits execution of the code.  Or
7918                    reverse the sense for elegance.)
7919
7920                    (Note that g77 could use a different test than NULL,
7921                    actually, since it happens to always pass an
7922                    integer to the called function that specifies which
7923                    entry point is being invoked.  Hmm, this might
7924                    solve the next problem.)
7925
7926                    One way a user could, I suppose, write "foo" so
7927                    it works is to insert COND_EXPR's for the
7928                    size/shape info so the dangerous stuff isn't
7929                    actually done, as in:
7930
7931                      void foo (int *n, float (*a)[(a == NULL) ? 0 : *n])
7932                      {
7933                        ...
7934                      }
7935
7936                    The next problem is that the front end needs to
7937                    be able to tell the back end about the array's
7938                    decl _before_ it tells it about the conditional
7939                    expression to inhibit evaluation of size/shape info,
7940                    as shown above.
7941
7942                    To solve this, the front end needs to be able
7943                    to give the back end the expression to inhibit
7944                    generation of the preevaluation code _after_
7945                    it makes the decl for the adjustable array.
7946
7947                    Until then, the above example using the COND_EXPR
7948                    doesn't pass muster with gcc because the "(a == NULL)"
7949                    part has a reference to "a", which is still
7950                    undefined at that point.
7951
7952                    g77 will therefore use a different mechanism in the
7953                    meantime.  */
7954
7955                 if (!adjustable
7956                     && ((TREE_CODE (low) != INTEGER_CST)
7957                         || (high && TREE_CODE (high) != INTEGER_CST)))
7958                   adjustable = TRUE;
7959
7960 #if 0                           /* Old approach -- see below. */
7961                 if (TREE_CODE (low) != INTEGER_CST)
7962                   low = ffecom_3 (COND_EXPR, integer_type_node,
7963                                   ffecom_adjarray_passed_ (s),
7964                                   low,
7965                                   ffecom_integer_zero_node);
7966
7967                 if (high && TREE_CODE (high) != INTEGER_CST)
7968                   high = ffecom_3 (COND_EXPR, integer_type_node,
7969                                    ffecom_adjarray_passed_ (s),
7970                                    high,
7971                                    ffecom_integer_zero_node);
7972 #endif
7973
7974                 /* ~~~gcc/stor-layout.c (layout_type) should do this,
7975                    probably.  Fixes 950302-1.f.  */
7976
7977                 if (TREE_CODE (low) != INTEGER_CST)
7978                   low = variable_size (low);
7979
7980                 /* ~~~Similarly, this fixes dumb0.f.  The C front end
7981                    does this, which is why dumb0.c would work.  */
7982
7983                 if (high && TREE_CODE (high) != INTEGER_CST)
7984                   high = variable_size (high);
7985
7986                 type
7987                   = build_array_type
7988                     (type,
7989                      build_range_type (ffecom_integer_type_node,
7990                                        low, high));
7991                 type = ffecom_check_size_overflow_ (s, type, TRUE);
7992               }
7993
7994             if (type == error_mark_node)
7995               {
7996                 t = error_mark_node;
7997                 break;
7998               }
7999
8000             if ((ffesymbol_sfdummyparent (s) == NULL)
8001                  || (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
8002               {
8003                 type = build_pointer_type (type);
8004                 addr = TRUE;
8005               }
8006
8007             t = build_decl (PARM_DECL, t, type);
8008 #if BUILT_FOR_270
8009             DECL_ARTIFICIAL (t) = 1;
8010 #endif
8011
8012             /* If this arg is present in every entry point's list of
8013                dummy args, then we're done.  */
8014
8015             if (ffesymbol_numentries (s)
8016                 == (ffecom_num_entrypoints_ + 1))
8017               break;
8018
8019 #if 1
8020
8021             /* If variable_size in stor-layout has been called during
8022                the above, then get_pending_sizes should have the
8023                yet-to-be-evaluated saved expressions pending.
8024                Make the whole lot of them get emitted, conditionally
8025                on whether the array decl ("t" above) is not NULL.  */
8026
8027             {
8028               tree sizes = get_pending_sizes ();
8029               tree tem;
8030
8031               for (tem = sizes;
8032                    tem != old_sizes;
8033                    tem = TREE_CHAIN (tem))
8034                 {
8035                   tree temv = TREE_VALUE (tem);
8036
8037                   if (sizes == tem)
8038                     sizes = temv;
8039                   else
8040                     sizes
8041                       = ffecom_2 (COMPOUND_EXPR,
8042                                   TREE_TYPE (sizes),
8043                                   temv,
8044                                   sizes);
8045                 }
8046
8047               if (sizes != tem)
8048                 {
8049                   sizes
8050                     = ffecom_3 (COND_EXPR,
8051                                 TREE_TYPE (sizes),
8052                                 ffecom_2 (NE_EXPR,
8053                                           integer_type_node,
8054                                           t,
8055                                           null_pointer_node),
8056                                 sizes,
8057                                 convert (TREE_TYPE (sizes),
8058                                          integer_zero_node));
8059                   sizes = ffecom_save_tree (sizes);
8060
8061                   sizes
8062                     = tree_cons (NULL_TREE, sizes, tem);
8063                 }
8064
8065               if (sizes)
8066                 put_pending_sizes (sizes);
8067             }
8068
8069 #else
8070 #if 0
8071             if (adjustable
8072                 && (ffesymbol_numentries (s)
8073                     != ffecom_num_entrypoints_ + 1))
8074               DECL_SOMETHING (t)
8075                 = ffecom_2 (NE_EXPR, integer_type_node,
8076                             t,
8077                             null_pointer_node);
8078 #else
8079 #if 0
8080             if (adjustable
8081                 && (ffesymbol_numentries (s)
8082                     != ffecom_num_entrypoints_ + 1))
8083               {
8084                 ffebad_start (FFEBAD_MISSING_ADJARRAY_UNSUPPORTED);
8085                 ffebad_here (0, ffesymbol_where_line (s),
8086                              ffesymbol_where_column (s));
8087                 ffebad_string (ffesymbol_text (s));
8088                 ffebad_finish ();
8089               }
8090 #endif
8091 #endif
8092 #endif
8093           }
8094           break;
8095
8096         case FFEINFO_whereCOMMON:
8097           {
8098             ffesymbol cs;
8099             ffeglobal cg;
8100             tree ct;
8101             ffestorag st = ffesymbol_storage (s);
8102             tree type;
8103
8104             cs = ffesymbol_common (s);  /* The COMMON area itself.  */
8105             if (st != NULL)     /* Else not laid out. */
8106               {
8107                 ffecom_transform_common_ (cs);
8108                 st = ffesymbol_storage (s);
8109               }
8110
8111             type = ffecom_type_localvar_ (s, bt, kt);
8112
8113             cg = ffesymbol_global (cs); /* The global COMMON info.  */
8114             if ((cg == NULL)
8115                 || (ffeglobal_type (cg) != FFEGLOBAL_typeCOMMON))
8116               ct = NULL_TREE;
8117             else
8118               ct = ffeglobal_hook (cg); /* The common area's tree.  */
8119
8120             if ((ct == NULL_TREE)
8121                 || (st == NULL)
8122                 || (type == error_mark_node))
8123               t = error_mark_node;
8124             else
8125               {
8126                 ffetargetOffset offset;
8127                 ffestorag cst;
8128
8129                 cst = ffestorag_parent (st);
8130                 assert (cst == ffesymbol_storage (cs));
8131
8132                 offset = ffestorag_modulo (cst)
8133                   + ffestorag_offset (st)
8134                   - ffestorag_offset (cst);
8135
8136                 ffecom_debug_kludge_ (ct, "COMMON", s, type, offset);
8137
8138                 /* (t_type *) (((char *) &ct) + offset) */
8139
8140                 t = convert (string_type_node,  /* (char *) */
8141                              ffecom_1 (ADDR_EXPR,
8142                                        build_pointer_type (TREE_TYPE (ct)),
8143                                        ct));
8144                 t = ffecom_2 (PLUS_EXPR, TREE_TYPE (t),
8145                               t,
8146                               build_int_2 (offset, 0));
8147                 t = convert (build_pointer_type (type),
8148                              t);
8149                 TREE_CONSTANT (t) = 1;
8150
8151                 addr = TRUE;
8152               }
8153           }
8154           break;
8155
8156         case FFEINFO_whereIMMEDIATE:
8157         case FFEINFO_whereGLOBAL:
8158         case FFEINFO_whereFLEETING:
8159         case FFEINFO_whereFLEETING_CADDR:
8160         case FFEINFO_whereFLEETING_IADDR:
8161         case FFEINFO_whereINTRINSIC:
8162         case FFEINFO_whereCONSTANT_SUBOBJECT:
8163         default:
8164           assert ("ENTITY where unheard of" == NULL);
8165           /* Fall through. */
8166         case FFEINFO_whereANY:
8167           t = error_mark_node;
8168           break;
8169         }
8170       break;
8171
8172     case FFEINFO_kindFUNCTION:
8173       switch (ffeinfo_where (ffesymbol_info (s)))
8174         {
8175         case FFEINFO_whereLOCAL:        /* Me. */
8176           assert (!ffecom_transform_only_dummies_);
8177           t = current_function_decl;
8178           break;
8179
8180         case FFEINFO_whereGLOBAL:
8181           assert (!ffecom_transform_only_dummies_);
8182
8183           if (((g = ffesymbol_global (s)) != NULL)
8184               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8185                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8186               && (ffeglobal_hook (g) != NULL_TREE)
8187               && ffe_is_globals ())
8188             {
8189               t = ffeglobal_hook (g);
8190               break;
8191             }
8192
8193           if (ffesymbol_is_f2c (s)
8194               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8195             t = ffecom_tree_fun_type[bt][kt];
8196           else
8197             t = build_function_type (ffecom_tree_type[bt][kt], NULL_TREE);
8198
8199           t = build_decl (FUNCTION_DECL,
8200                           ffecom_get_external_identifier_ (s),
8201                           t);
8202           DECL_EXTERNAL (t) = 1;
8203           TREE_PUBLIC (t) = 1;
8204
8205           t = start_decl (t, FALSE);
8206           finish_decl (t, NULL_TREE, FALSE);
8207
8208           if ((g != NULL)
8209               && ((ffeglobal_type (g) == FFEGLOBAL_typeFUNC)
8210                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8211             ffeglobal_set_hook (g, t);
8212
8213           ffecom_save_tree_forever (t);
8214
8215           break;
8216
8217         case FFEINFO_whereDUMMY:
8218           assert (ffecom_transform_only_dummies_);
8219
8220           if (ffesymbol_is_f2c (s)
8221               && (ffesymbol_where (s) != FFEINFO_whereCONSTANT))
8222             t = ffecom_tree_ptr_to_fun_type[bt][kt];
8223           else
8224             t = build_pointer_type
8225               (build_function_type (ffecom_tree_type[bt][kt], NULL_TREE));
8226
8227           t = build_decl (PARM_DECL,
8228                           ffecom_get_identifier_ (ffesymbol_text (s)),
8229                           t);
8230 #if BUILT_FOR_270
8231           DECL_ARTIFICIAL (t) = 1;
8232 #endif
8233           addr = TRUE;
8234           break;
8235
8236         case FFEINFO_whereCONSTANT:     /* Statement function. */
8237           assert (!ffecom_transform_only_dummies_);
8238           t = ffecom_gen_sfuncdef_ (s, bt, kt);
8239           break;
8240
8241         case FFEINFO_whereINTRINSIC:
8242           assert (!ffecom_transform_only_dummies_);
8243           break;                /* Let actual references generate their
8244                                    decls. */
8245
8246         default:
8247           assert ("FUNCTION where unheard of" == NULL);
8248           /* Fall through. */
8249         case FFEINFO_whereANY:
8250           t = error_mark_node;
8251           break;
8252         }
8253       break;
8254
8255     case FFEINFO_kindSUBROUTINE:
8256       switch (ffeinfo_where (ffesymbol_info (s)))
8257         {
8258         case FFEINFO_whereLOCAL:        /* Me. */
8259           assert (!ffecom_transform_only_dummies_);
8260           t = current_function_decl;
8261           break;
8262
8263         case FFEINFO_whereGLOBAL:
8264           assert (!ffecom_transform_only_dummies_);
8265
8266           if (((g = ffesymbol_global (s)) != NULL)
8267               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8268                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT))
8269               && (ffeglobal_hook (g) != NULL_TREE)
8270               && ffe_is_globals ())
8271             {
8272               t = ffeglobal_hook (g);
8273               break;
8274             }
8275
8276           t = build_decl (FUNCTION_DECL,
8277                           ffecom_get_external_identifier_ (s),
8278                           ffecom_tree_subr_type);
8279           DECL_EXTERNAL (t) = 1;
8280           TREE_PUBLIC (t) = 1;
8281
8282           t = start_decl (t, FALSE);
8283           finish_decl (t, NULL_TREE, FALSE);
8284
8285           if ((g != NULL)
8286               && ((ffeglobal_type (g) == FFEGLOBAL_typeSUBR)
8287                   || (ffeglobal_type (g) == FFEGLOBAL_typeEXT)))
8288             ffeglobal_set_hook (g, t);
8289
8290           ffecom_save_tree_forever (t);
8291
8292           break;
8293
8294         case FFEINFO_whereDUMMY:
8295           assert (ffecom_transform_only_dummies_);
8296
8297           t = build_decl (PARM_DECL,
8298                           ffecom_get_identifier_ (ffesymbol_text (s)),
8299                           ffecom_tree_ptr_to_subr_type);
8300 #if BUILT_FOR_270
8301           DECL_ARTIFICIAL (t) = 1;
8302 #endif
8303           addr = TRUE;
8304           break;
8305
8306         case FFEINFO_whereINTRINSIC:
8307           assert (!ffecom_transform_only_dummies_);
8308           break;                /* Let actual references generate their
8309                                    decls. */
8310
8311         default:
8312           assert ("SUBROUTINE where unheard of" == NULL);
8313           /* Fall through. */
8314         case FFEINFO_whereANY:
8315           t = error_mark_node;
8316           break;
8317         }
8318       break;
8319
8320     case FFEINFO_kindPROGRAM:
8321       switch (ffeinfo_where (ffesymbol_info (s)))
8322         {
8323         case FFEINFO_whereLOCAL:        /* Me. */
8324           assert (!ffecom_transform_only_dummies_);
8325           t = current_function_decl;
8326           break;
8327
8328         case FFEINFO_whereCOMMON:
8329         case FFEINFO_whereDUMMY:
8330         case FFEINFO_whereGLOBAL:
8331         case FFEINFO_whereRESULT:
8332         case FFEINFO_whereFLEETING:
8333         case FFEINFO_whereFLEETING_CADDR:
8334         case FFEINFO_whereFLEETING_IADDR:
8335         case FFEINFO_whereIMMEDIATE:
8336         case FFEINFO_whereINTRINSIC:
8337         case FFEINFO_whereCONSTANT:
8338         case FFEINFO_whereCONSTANT_SUBOBJECT:
8339         default:
8340           assert ("PROGRAM where unheard of" == NULL);
8341           /* Fall through. */
8342         case FFEINFO_whereANY:
8343           t = error_mark_node;
8344           break;
8345         }
8346       break;
8347
8348     case FFEINFO_kindBLOCKDATA:
8349       switch (ffeinfo_where (ffesymbol_info (s)))
8350         {
8351         case FFEINFO_whereLOCAL:        /* Me. */
8352           assert (!ffecom_transform_only_dummies_);
8353           t = current_function_decl;
8354           break;
8355
8356         case FFEINFO_whereGLOBAL:
8357           assert (!ffecom_transform_only_dummies_);
8358
8359           t = build_decl (FUNCTION_DECL,
8360                           ffecom_get_external_identifier_ (s),
8361                           ffecom_tree_blockdata_type);
8362           DECL_EXTERNAL (t) = 1;
8363           TREE_PUBLIC (t) = 1;
8364
8365           t = start_decl (t, FALSE);
8366           finish_decl (t, NULL_TREE, FALSE);
8367
8368           ffecom_save_tree_forever (t);
8369
8370           break;
8371
8372         case FFEINFO_whereCOMMON:
8373         case FFEINFO_whereDUMMY:
8374         case FFEINFO_whereRESULT:
8375         case FFEINFO_whereFLEETING:
8376         case FFEINFO_whereFLEETING_CADDR:
8377         case FFEINFO_whereFLEETING_IADDR:
8378         case FFEINFO_whereIMMEDIATE:
8379         case FFEINFO_whereINTRINSIC:
8380         case FFEINFO_whereCONSTANT:
8381         case FFEINFO_whereCONSTANT_SUBOBJECT:
8382         default:
8383           assert ("BLOCKDATA where unheard of" == NULL);
8384           /* Fall through. */
8385         case FFEINFO_whereANY:
8386           t = error_mark_node;
8387           break;
8388         }
8389       break;
8390
8391     case FFEINFO_kindCOMMON:
8392       switch (ffeinfo_where (ffesymbol_info (s)))
8393         {
8394         case FFEINFO_whereLOCAL:
8395           assert (!ffecom_transform_only_dummies_);
8396           ffecom_transform_common_ (s);
8397           break;
8398
8399         case FFEINFO_whereNONE:
8400         case FFEINFO_whereCOMMON:
8401         case FFEINFO_whereDUMMY:
8402         case FFEINFO_whereGLOBAL:
8403         case FFEINFO_whereRESULT:
8404         case FFEINFO_whereFLEETING:
8405         case FFEINFO_whereFLEETING_CADDR:
8406         case FFEINFO_whereFLEETING_IADDR:
8407         case FFEINFO_whereIMMEDIATE:
8408         case FFEINFO_whereINTRINSIC:
8409         case FFEINFO_whereCONSTANT:
8410         case FFEINFO_whereCONSTANT_SUBOBJECT:
8411         default:
8412           assert ("COMMON where unheard of" == NULL);
8413           /* Fall through. */
8414         case FFEINFO_whereANY:
8415           t = error_mark_node;
8416           break;
8417         }
8418       break;
8419
8420     case FFEINFO_kindCONSTRUCT:
8421       switch (ffeinfo_where (ffesymbol_info (s)))
8422         {
8423         case FFEINFO_whereLOCAL:
8424           assert (!ffecom_transform_only_dummies_);
8425           break;
8426
8427         case FFEINFO_whereNONE:
8428         case FFEINFO_whereCOMMON:
8429         case FFEINFO_whereDUMMY:
8430         case FFEINFO_whereGLOBAL:
8431         case FFEINFO_whereRESULT:
8432         case FFEINFO_whereFLEETING:
8433         case FFEINFO_whereFLEETING_CADDR:
8434         case FFEINFO_whereFLEETING_IADDR:
8435         case FFEINFO_whereIMMEDIATE:
8436         case FFEINFO_whereINTRINSIC:
8437         case FFEINFO_whereCONSTANT:
8438         case FFEINFO_whereCONSTANT_SUBOBJECT:
8439         default:
8440           assert ("CONSTRUCT where unheard of" == NULL);
8441           /* Fall through. */
8442         case FFEINFO_whereANY:
8443           t = error_mark_node;
8444           break;
8445         }
8446       break;
8447
8448     case FFEINFO_kindNAMELIST:
8449       switch (ffeinfo_where (ffesymbol_info (s)))
8450         {
8451         case FFEINFO_whereLOCAL:
8452           assert (!ffecom_transform_only_dummies_);
8453           t = ffecom_transform_namelist_ (s);
8454           break;
8455
8456         case FFEINFO_whereNONE:
8457         case FFEINFO_whereCOMMON:
8458         case FFEINFO_whereDUMMY:
8459         case FFEINFO_whereGLOBAL:
8460         case FFEINFO_whereRESULT:
8461         case FFEINFO_whereFLEETING:
8462         case FFEINFO_whereFLEETING_CADDR:
8463         case FFEINFO_whereFLEETING_IADDR:
8464         case FFEINFO_whereIMMEDIATE:
8465         case FFEINFO_whereINTRINSIC:
8466         case FFEINFO_whereCONSTANT:
8467         case FFEINFO_whereCONSTANT_SUBOBJECT:
8468         default:
8469           assert ("NAMELIST where unheard of" == NULL);
8470           /* Fall through. */
8471         case FFEINFO_whereANY:
8472           t = error_mark_node;
8473           break;
8474         }
8475       break;
8476
8477     default:
8478       assert ("kind unheard of" == NULL);
8479       /* Fall through. */
8480     case FFEINFO_kindANY:
8481       t = error_mark_node;
8482       break;
8483     }
8484
8485   ffesymbol_hook (s).decl_tree = t;
8486   ffesymbol_hook (s).length_tree = tlen;
8487   ffesymbol_hook (s).addr = addr;
8488
8489   lineno = old_lineno;
8490   input_filename = old_input_filename;
8491
8492   return s;
8493 }
8494
8495 #endif
8496 /* Transform into ASSIGNable symbol.
8497
8498    Symbol has already been transformed, but for whatever reason, the
8499    resulting decl_tree has been deemed not usable for an ASSIGN target.
8500    (E.g. it isn't wide enough to hold a pointer.)  So, here we invent
8501    another local symbol of type void * and stuff that in the assign_tree
8502    argument.  The F77/F90 standards allow this implementation.  */
8503
8504 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8505 static ffesymbol
8506 ffecom_sym_transform_assign_ (ffesymbol s)
8507 {
8508   tree t;                       /* Transformed thingy. */
8509   int old_lineno = lineno;
8510   const char *old_input_filename = input_filename;
8511
8512   if (ffesymbol_sfdummyparent (s) == NULL)
8513     {
8514       input_filename = ffesymbol_where_filename (s);
8515       lineno = ffesymbol_where_filelinenum (s);
8516     }
8517   else
8518     {
8519       ffesymbol sf = ffesymbol_sfdummyparent (s);
8520
8521       input_filename = ffesymbol_where_filename (sf);
8522       lineno = ffesymbol_where_filelinenum (sf);
8523     }
8524
8525   assert (!ffecom_transform_only_dummies_);
8526
8527   t = build_decl (VAR_DECL,
8528                   ffecom_get_invented_identifier ("__g77_ASSIGN_%s",
8529                                                    ffesymbol_text (s)),
8530                   TREE_TYPE (null_pointer_node));
8531
8532   switch (ffesymbol_where (s))
8533     {
8534     case FFEINFO_whereLOCAL:
8535       /* Unlike for regular vars, SAVE status is easy to determine for
8536          ASSIGNed vars, since there's no initialization, there's no
8537          effective storage association (so "SAVE J" does not apply to
8538          K even given "EQUIVALENCE (J,K)"), there's no size issue
8539          to worry about, etc.  */
8540       if ((ffesymbol_is_save (s) || ffe_is_saveall ())
8541           && (ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8542           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA))
8543         TREE_STATIC (t) = 1;    /* SAVEd in proc, make static. */
8544       else
8545         TREE_STATIC (t) = 0;    /* No need to make static. */
8546       break;
8547
8548     case FFEINFO_whereCOMMON:
8549       TREE_STATIC (t) = 1;      /* Assume COMMONs always SAVEd. */
8550       break;
8551
8552     case FFEINFO_whereDUMMY:
8553       /* Note that twinning a DUMMY means the caller won't see
8554          the ASSIGNed value.  But both F77 and F90 allow implementations
8555          to do this, i.e. disallow Fortran code that would try and
8556          take advantage of actually putting a label into a variable
8557          via a dummy argument (or any other storage association, for
8558          that matter).  */
8559       TREE_STATIC (t) = 0;
8560       break;
8561
8562     default:
8563       TREE_STATIC (t) = 0;
8564       break;
8565     }
8566
8567   t = start_decl (t, FALSE);
8568   finish_decl (t, NULL_TREE, FALSE);
8569
8570   ffesymbol_hook (s).assign_tree = t;
8571
8572   lineno = old_lineno;
8573   input_filename = old_input_filename;
8574
8575   return s;
8576 }
8577
8578 #endif
8579 /* Implement COMMON area in back end.
8580
8581    Because COMMON-based variables can be referenced in the dimension
8582    expressions of dummy (adjustable) arrays, and because dummies
8583    (in the gcc back end) need to be put in the outer binding level
8584    of a function (which has two binding levels, the outer holding
8585    the dummies and the inner holding the other vars), special care
8586    must be taken to handle COMMON areas.
8587
8588    The current strategy is basically to always tell the back end about
8589    the COMMON area as a top-level external reference to just a block
8590    of storage of the master type of that area (e.g. integer, real,
8591    character, whatever -- not a structure).  As a distinct action,
8592    if initial values are provided, tell the back end about the area
8593    as a top-level non-external (initialized) area and remember not to
8594    allow further initialization or expansion of the area.  Meanwhile,
8595    if no initialization happens at all, tell the back end about
8596    the largest size we've seen declared so the space does get reserved.
8597    (This function doesn't handle all that stuff, but it does some
8598    of the important things.)
8599
8600    Meanwhile, for COMMON variables themselves, just keep creating
8601    references like *((float *) (&common_area + offset)) each time
8602    we reference the variable.  In other words, don't make a VAR_DECL
8603    or any kind of component reference (like we used to do before 0.4),
8604    though we might do that as well just for debugging purposes (and
8605    stuff the rtl with the appropriate offset expression).  */
8606
8607 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8608 static void
8609 ffecom_transform_common_ (ffesymbol s)
8610 {
8611   ffestorag st = ffesymbol_storage (s);
8612   ffeglobal g = ffesymbol_global (s);
8613   tree cbt;
8614   tree cbtype;
8615   tree init;
8616   tree high;
8617   bool is_init = ffestorag_is_init (st);
8618
8619   assert (st != NULL);
8620
8621   if ((g == NULL)
8622       || (ffeglobal_type (g) != FFEGLOBAL_typeCOMMON))
8623     return;
8624
8625   /* First update the size of the area in global terms.  */
8626
8627   ffeglobal_size_common (s, ffestorag_size (st));
8628
8629   if (!ffeglobal_common_init (g))
8630     is_init = FALSE;    /* No explicit init, don't let erroneous joins init. */
8631
8632   cbt = ffeglobal_hook (g);
8633
8634   /* If we already have declared this common block for a previous program
8635      unit, and either we already initialized it or we don't have new
8636      initialization for it, just return what we have without changing it.  */
8637
8638   if ((cbt != NULL_TREE)
8639       && (!is_init
8640           || !DECL_EXTERNAL (cbt)))
8641     {
8642       if (st->hook == NULL) ffestorag_set_hook (st, cbt);
8643       return;
8644     }
8645
8646   /* Process inits.  */
8647
8648   if (is_init)
8649     {
8650       if (ffestorag_init (st) != NULL)
8651         {
8652           ffebld sexp;
8653
8654           /* Set the padding for the expression, so ffecom_expr
8655              knows to insert that many zeros.  */
8656           switch (ffebld_op (sexp = ffestorag_init (st)))
8657             {
8658             case FFEBLD_opCONTER:
8659               ffebld_conter_set_pad (sexp, ffestorag_modulo (st));
8660               break;
8661
8662             case FFEBLD_opARRTER:
8663               ffebld_arrter_set_pad (sexp, ffestorag_modulo (st));
8664               break;
8665
8666             case FFEBLD_opACCTER:
8667               ffebld_accter_set_pad (sexp, ffestorag_modulo (st));
8668               break;
8669
8670             default:
8671               assert ("bad op for cmn init (pad)" == NULL);
8672               break;
8673             }
8674
8675           init = ffecom_expr (sexp);
8676           if (init == error_mark_node)
8677             {                   /* Hopefully the back end complained! */
8678               init = NULL_TREE;
8679               if (cbt != NULL_TREE)
8680                 return;
8681             }
8682         }
8683       else
8684         init = error_mark_node;
8685     }
8686   else
8687     init = NULL_TREE;
8688
8689   /* cbtype must be permanently allocated!  */
8690
8691   /* Allocate the MAX of the areas so far, seen filewide.  */
8692   high = build_int_2 ((ffeglobal_common_size (g)
8693                        + ffeglobal_common_pad (g)) - 1, 0);
8694   TREE_TYPE (high) = ffecom_integer_type_node;
8695
8696   if (init)
8697     cbtype = build_array_type (char_type_node,
8698                                build_range_type (integer_type_node,
8699                                                  integer_zero_node,
8700                                                  high));
8701   else
8702     cbtype = build_array_type (char_type_node, NULL_TREE);
8703
8704   if (cbt == NULL_TREE)
8705     {
8706       cbt
8707         = build_decl (VAR_DECL,
8708                       ffecom_get_external_identifier_ (s),
8709                       cbtype);
8710       TREE_STATIC (cbt) = 1;
8711       TREE_PUBLIC (cbt) = 1;
8712     }
8713   else
8714     {
8715       assert (is_init);
8716       TREE_TYPE (cbt) = cbtype;
8717     }
8718   DECL_EXTERNAL (cbt) = init ? 0 : 1;
8719   DECL_INITIAL (cbt) = init ? error_mark_node : NULL_TREE;
8720
8721   cbt = start_decl (cbt, TRUE);
8722   if (ffeglobal_hook (g) != NULL)
8723     assert (cbt == ffeglobal_hook (g));
8724
8725   assert (!init || !DECL_EXTERNAL (cbt));
8726
8727   /* Make sure that any type can live in COMMON and be referenced
8728      without getting a bus error.  We could pick the most restrictive
8729      alignment of all entities actually placed in the COMMON, but
8730      this seems easy enough.  */
8731
8732   DECL_ALIGN (cbt) = BIGGEST_ALIGNMENT;
8733   DECL_USER_ALIGN (cbt) = 0;
8734
8735   if (is_init && (ffestorag_init (st) == NULL))
8736     init = ffecom_init_zero_ (cbt);
8737
8738   finish_decl (cbt, init, TRUE);
8739
8740   if (is_init)
8741     ffestorag_set_init (st, ffebld_new_any ());
8742
8743   if (init)
8744     {
8745       assert (DECL_SIZE_UNIT (cbt) != NULL_TREE);
8746       assert (TREE_CODE (DECL_SIZE_UNIT (cbt)) == INTEGER_CST);
8747       assert (0 == compare_tree_int (DECL_SIZE_UNIT (cbt),
8748                                      (ffeglobal_common_size (g)
8749                                       + ffeglobal_common_pad (g))));
8750     }
8751
8752   ffeglobal_set_hook (g, cbt);
8753
8754   ffestorag_set_hook (st, cbt);
8755
8756   ffecom_save_tree_forever (cbt);
8757 }
8758
8759 #endif
8760 /* Make master area for local EQUIVALENCE.  */
8761
8762 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8763 static void
8764 ffecom_transform_equiv_ (ffestorag eqst)
8765 {
8766   tree eqt;
8767   tree eqtype;
8768   tree init;
8769   tree high;
8770   bool is_init = ffestorag_is_init (eqst);
8771
8772   assert (eqst != NULL);
8773
8774   eqt = ffestorag_hook (eqst);
8775
8776   if (eqt != NULL_TREE)
8777     return;
8778
8779   /* Process inits.  */
8780
8781   if (is_init)
8782     {
8783       if (ffestorag_init (eqst) != NULL)
8784         {
8785           ffebld sexp;
8786
8787           /* Set the padding for the expression, so ffecom_expr
8788              knows to insert that many zeros.  */
8789           switch (ffebld_op (sexp = ffestorag_init (eqst)))
8790             {
8791             case FFEBLD_opCONTER:
8792               ffebld_conter_set_pad (sexp, ffestorag_modulo (eqst));
8793               break;
8794
8795             case FFEBLD_opARRTER:
8796               ffebld_arrter_set_pad (sexp, ffestorag_modulo (eqst));
8797               break;
8798
8799             case FFEBLD_opACCTER:
8800               ffebld_accter_set_pad (sexp, ffestorag_modulo (eqst));
8801               break;
8802
8803             default:
8804               assert ("bad op for eqv init (pad)" == NULL);
8805               break;
8806             }
8807
8808           init = ffecom_expr (sexp);
8809           if (init == error_mark_node)
8810             init = NULL_TREE;   /* Hopefully the back end complained! */
8811         }
8812       else
8813         init = error_mark_node;
8814     }
8815   else if (ffe_is_init_local_zero ())
8816     init = error_mark_node;
8817   else
8818     init = NULL_TREE;
8819
8820   ffecom_member_namelisted_ = FALSE;
8821   ffestorag_drive (ffestorag_list_equivs (eqst),
8822                    &ffecom_member_phase1_,
8823                    eqst);
8824
8825   high = build_int_2 ((ffestorag_size (eqst)
8826                        + ffestorag_modulo (eqst)) - 1, 0);
8827   TREE_TYPE (high) = ffecom_integer_type_node;
8828
8829   eqtype = build_array_type (char_type_node,
8830                              build_range_type (ffecom_integer_type_node,
8831                                                ffecom_integer_zero_node,
8832                                                high));
8833
8834   eqt = build_decl (VAR_DECL,
8835                     ffecom_get_invented_identifier ("__g77_equiv_%s",
8836                                                     ffesymbol_text
8837                                                     (ffestorag_symbol (eqst))),
8838                     eqtype);
8839   DECL_EXTERNAL (eqt) = 0;
8840   if (is_init
8841       || ffecom_member_namelisted_
8842 #ifdef FFECOM_sizeMAXSTACKITEM
8843       || (ffestorag_size (eqst) > FFECOM_sizeMAXSTACKITEM)
8844 #endif
8845       || ((ffecom_primary_entry_kind_ != FFEINFO_kindPROGRAM)
8846           && (ffecom_primary_entry_kind_ != FFEINFO_kindBLOCKDATA)
8847           && (ffestorag_is_save (eqst) || ffe_is_saveall ())))
8848     TREE_STATIC (eqt) = 1;
8849   else
8850     TREE_STATIC (eqt) = 0;
8851   TREE_PUBLIC (eqt) = 0;
8852   TREE_ADDRESSABLE (eqt) = 1;  /* Ensure non-register allocation */
8853   DECL_CONTEXT (eqt) = current_function_decl;
8854   if (init)
8855     DECL_INITIAL (eqt) = error_mark_node;
8856   else
8857     DECL_INITIAL (eqt) = NULL_TREE;
8858
8859   eqt = start_decl (eqt, FALSE);
8860
8861   /* Make sure that any type can live in EQUIVALENCE and be referenced
8862      without getting a bus error.  We could pick the most restrictive
8863      alignment of all entities actually placed in the EQUIVALENCE, but
8864      this seems easy enough.  */
8865
8866   DECL_ALIGN (eqt) = BIGGEST_ALIGNMENT;
8867   DECL_USER_ALIGN (eqt) = 0;
8868
8869   if ((!is_init && ffe_is_init_local_zero ())
8870       || (is_init && (ffestorag_init (eqst) == NULL)))
8871     init = ffecom_init_zero_ (eqt);
8872
8873   finish_decl (eqt, init, FALSE);
8874
8875   if (is_init)
8876     ffestorag_set_init (eqst, ffebld_new_any ());
8877
8878   {
8879     assert (TREE_CODE (DECL_SIZE_UNIT (eqt)) == INTEGER_CST);
8880     assert (0 == compare_tree_int (DECL_SIZE_UNIT (eqt),
8881                                    (ffestorag_size (eqst)
8882                                     + ffestorag_modulo (eqst))));
8883   }
8884
8885   ffestorag_set_hook (eqst, eqt);
8886
8887   ffestorag_drive (ffestorag_list_equivs (eqst),
8888                    &ffecom_member_phase2_,
8889                    eqst);
8890 }
8891
8892 #endif
8893 /* Implement NAMELIST in back end.  See f2c/format.c for more info.  */
8894
8895 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8896 static tree
8897 ffecom_transform_namelist_ (ffesymbol s)
8898 {
8899   tree nmlt;
8900   tree nmltype = ffecom_type_namelist_ ();
8901   tree nmlinits;
8902   tree nameinit;
8903   tree varsinit;
8904   tree nvarsinit;
8905   tree field;
8906   tree high;
8907   int i;
8908   static int mynumber = 0;
8909
8910   nmlt = build_decl (VAR_DECL,
8911                      ffecom_get_invented_identifier ("__g77_namelist_%d",
8912                                                      mynumber++),
8913                      nmltype);
8914   TREE_STATIC (nmlt) = 1;
8915   DECL_INITIAL (nmlt) = error_mark_node;
8916
8917   nmlt = start_decl (nmlt, FALSE);
8918
8919   /* Process inits.  */
8920
8921   i = strlen (ffesymbol_text (s));
8922
8923   high = build_int_2 (i, 0);
8924   TREE_TYPE (high) = ffecom_f2c_ftnlen_type_node;
8925
8926   nameinit = ffecom_build_f2c_string_ (i + 1,
8927                                        ffesymbol_text (s));
8928   TREE_TYPE (nameinit)
8929     = build_type_variant
8930     (build_array_type
8931      (char_type_node,
8932       build_range_type (ffecom_f2c_ftnlen_type_node,
8933                         ffecom_f2c_ftnlen_one_node,
8934                         high)),
8935      1, 0);
8936   TREE_CONSTANT (nameinit) = 1;
8937   TREE_STATIC (nameinit) = 1;
8938   nameinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (nameinit)),
8939                        nameinit);
8940
8941   varsinit = ffecom_vardesc_array_ (s);
8942   varsinit = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (varsinit)),
8943                        varsinit);
8944   TREE_CONSTANT (varsinit) = 1;
8945   TREE_STATIC (varsinit) = 1;
8946
8947   {
8948     ffebld b;
8949
8950     for (i = 0, b = ffesymbol_namelist (s); b != NULL; b = ffebld_trail (b))
8951       ++i;
8952   }
8953   nvarsinit = build_int_2 (i, 0);
8954   TREE_TYPE (nvarsinit) = integer_type_node;
8955   TREE_CONSTANT (nvarsinit) = 1;
8956   TREE_STATIC (nvarsinit) = 1;
8957
8958   nmlinits = build_tree_list ((field = TYPE_FIELDS (nmltype)), nameinit);
8959   TREE_CHAIN (nmlinits) = build_tree_list ((field = TREE_CHAIN (field)),
8960                                            varsinit);
8961   TREE_CHAIN (TREE_CHAIN (nmlinits))
8962     = build_tree_list ((field = TREE_CHAIN (field)), nvarsinit);
8963
8964   nmlinits = build (CONSTRUCTOR, nmltype, NULL_TREE, nmlinits);
8965   TREE_CONSTANT (nmlinits) = 1;
8966   TREE_STATIC (nmlinits) = 1;
8967
8968   finish_decl (nmlt, nmlinits, FALSE);
8969
8970   nmlt = ffecom_1 (ADDR_EXPR, build_pointer_type (nmltype), nmlt);
8971
8972   return nmlt;
8973 }
8974
8975 #endif
8976
8977 /* A subroutine of ffecom_tree_canonize_ref_.  The incoming tree is
8978    analyzed on the assumption it is calculating a pointer to be
8979    indirected through.  It must return the proper decl and offset,
8980    taking into account different units of measurements for offsets.  */
8981
8982 #if FFECOM_targetCURRENT == FFECOM_targetGCC
8983 static void
8984 ffecom_tree_canonize_ptr_ (tree *decl, tree *offset,
8985                            tree t)
8986 {
8987   switch (TREE_CODE (t))
8988     {
8989     case NOP_EXPR:
8990     case CONVERT_EXPR:
8991     case NON_LVALUE_EXPR:
8992       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
8993       break;
8994
8995     case PLUS_EXPR:
8996       ffecom_tree_canonize_ptr_ (decl, offset, TREE_OPERAND (t, 0));
8997       if ((*decl == NULL_TREE)
8998           || (*decl == error_mark_node))
8999         break;
9000
9001       if (TREE_CODE (TREE_OPERAND (t, 1)) == INTEGER_CST)
9002         {
9003           /* An offset into COMMON.  */
9004           *offset = fold (build (PLUS_EXPR, TREE_TYPE (*offset),
9005                                  *offset, TREE_OPERAND (t, 1)));
9006           /* Convert offset (presumably in bytes) into canonical units
9007              (presumably bits).  */
9008           *offset = size_binop (MULT_EXPR,
9009                                 convert (bitsizetype, *offset),
9010                                 TYPE_SIZE (TREE_TYPE (TREE_TYPE (t))));
9011           break;
9012         }
9013       /* Not a COMMON reference, so an unrecognized pattern.  */
9014       *decl = error_mark_node;
9015       break;
9016
9017     case PARM_DECL:
9018       *decl = t;
9019       *offset = bitsize_zero_node;
9020       break;
9021
9022     case ADDR_EXPR:
9023       if (TREE_CODE (TREE_OPERAND (t, 0)) == VAR_DECL)
9024         {
9025           /* A reference to COMMON.  */
9026           *decl = TREE_OPERAND (t, 0);
9027           *offset = bitsize_zero_node;
9028           break;
9029         }
9030       /* Fall through.  */
9031     default:
9032       /* Not a COMMON reference, so an unrecognized pattern.  */
9033       *decl = error_mark_node;
9034       break;
9035     }
9036 }
9037 #endif
9038
9039 /* Given a tree that is possibly intended for use as an lvalue, return
9040    information representing a canonical view of that tree as a decl, an
9041    offset into that decl, and a size for the lvalue.
9042
9043    If there's no applicable decl, NULL_TREE is returned for the decl,
9044    and the other fields are left undefined.
9045
9046    If the tree doesn't fit the recognizable forms, an ERROR_MARK node
9047    is returned for the decl, and the other fields are left undefined.
9048
9049    Otherwise, the decl returned currently is either a VAR_DECL or a
9050    PARM_DECL.
9051
9052    The offset returned is always valid, but of course not necessarily
9053    a constant, and not necessarily converted into the appropriate
9054    type, leaving that up to the caller (so as to avoid that overhead
9055    if the decls being looked at are different anyway).
9056
9057    If the size cannot be determined (e.g. an adjustable array),
9058    an ERROR_MARK node is returned for the size.  Otherwise, the
9059    size returned is valid, not necessarily a constant, and not
9060    necessarily converted into the appropriate type as with the
9061    offset.
9062
9063    Note that the offset and size expressions are expressed in the
9064    base storage units (usually bits) rather than in the units of
9065    the type of the decl, because two decls with different types
9066    might overlap but with apparently non-overlapping array offsets,
9067    whereas converting the array offsets to consistant offsets will
9068    reveal the overlap.  */
9069
9070 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9071 static void
9072 ffecom_tree_canonize_ref_ (tree *decl, tree *offset,
9073                            tree *size, tree t)
9074 {
9075   /* The default path is to report a nonexistant decl.  */
9076   *decl = NULL_TREE;
9077
9078   if (t == NULL_TREE)
9079     return;
9080
9081   switch (TREE_CODE (t))
9082     {
9083     case ERROR_MARK:
9084     case IDENTIFIER_NODE:
9085     case INTEGER_CST:
9086     case REAL_CST:
9087     case COMPLEX_CST:
9088     case STRING_CST:
9089     case CONST_DECL:
9090     case PLUS_EXPR:
9091     case MINUS_EXPR:
9092     case MULT_EXPR:
9093     case TRUNC_DIV_EXPR:
9094     case CEIL_DIV_EXPR:
9095     case FLOOR_DIV_EXPR:
9096     case ROUND_DIV_EXPR:
9097     case TRUNC_MOD_EXPR:
9098     case CEIL_MOD_EXPR:
9099     case FLOOR_MOD_EXPR:
9100     case ROUND_MOD_EXPR:
9101     case RDIV_EXPR:
9102     case EXACT_DIV_EXPR:
9103     case FIX_TRUNC_EXPR:
9104     case FIX_CEIL_EXPR:
9105     case FIX_FLOOR_EXPR:
9106     case FIX_ROUND_EXPR:
9107     case FLOAT_EXPR:
9108     case EXPON_EXPR:
9109     case NEGATE_EXPR:
9110     case MIN_EXPR:
9111     case MAX_EXPR:
9112     case ABS_EXPR:
9113     case FFS_EXPR:
9114     case LSHIFT_EXPR:
9115     case RSHIFT_EXPR:
9116     case LROTATE_EXPR:
9117     case RROTATE_EXPR:
9118     case BIT_IOR_EXPR:
9119     case BIT_XOR_EXPR:
9120     case BIT_AND_EXPR:
9121     case BIT_ANDTC_EXPR:
9122     case BIT_NOT_EXPR:
9123     case TRUTH_ANDIF_EXPR:
9124     case TRUTH_ORIF_EXPR:
9125     case TRUTH_AND_EXPR:
9126     case TRUTH_OR_EXPR:
9127     case TRUTH_XOR_EXPR:
9128     case TRUTH_NOT_EXPR:
9129     case LT_EXPR:
9130     case LE_EXPR:
9131     case GT_EXPR:
9132     case GE_EXPR:
9133     case EQ_EXPR:
9134     case NE_EXPR:
9135     case COMPLEX_EXPR:
9136     case CONJ_EXPR:
9137     case REALPART_EXPR:
9138     case IMAGPART_EXPR:
9139     case LABEL_EXPR:
9140     case COMPONENT_REF:
9141     case COMPOUND_EXPR:
9142     case ADDR_EXPR:
9143       return;
9144
9145     case VAR_DECL:
9146     case PARM_DECL:
9147       *decl = t;
9148       *offset = bitsize_zero_node;
9149       *size = TYPE_SIZE (TREE_TYPE (t));
9150       return;
9151
9152     case ARRAY_REF:
9153       {
9154         tree array = TREE_OPERAND (t, 0);
9155         tree element = TREE_OPERAND (t, 1);
9156         tree init_offset;
9157
9158         if ((array == NULL_TREE)
9159             || (element == NULL_TREE))
9160           {
9161             *decl = error_mark_node;
9162             return;
9163           }
9164
9165         ffecom_tree_canonize_ref_ (decl, &init_offset, size,
9166                                    array);
9167         if ((*decl == NULL_TREE)
9168             || (*decl == error_mark_node))
9169           return;
9170
9171         /* Calculate ((element - base) * NBBY) + init_offset.  */
9172         *offset = fold (build (MINUS_EXPR, TREE_TYPE (element),
9173                                element,
9174                                TYPE_MIN_VALUE (TYPE_DOMAIN
9175                                                (TREE_TYPE (array)))));
9176
9177         *offset = size_binop (MULT_EXPR,
9178                               convert (bitsizetype, *offset),
9179                               TYPE_SIZE (TREE_TYPE (TREE_TYPE (array))));
9180
9181         *offset = size_binop (PLUS_EXPR, init_offset, *offset);
9182
9183         *size = TYPE_SIZE (TREE_TYPE (t));
9184         return;
9185       }
9186
9187     case INDIRECT_REF:
9188
9189       /* Most of this code is to handle references to COMMON.  And so
9190          far that is useful only for calling library functions, since
9191          external (user) functions might reference common areas.  But
9192          even calling an external function, it's worthwhile to decode
9193          COMMON references because if not storing into COMMON, we don't
9194          want COMMON-based arguments to gratuitously force use of a
9195          temporary.  */
9196
9197       *size = TYPE_SIZE (TREE_TYPE (t));
9198
9199       ffecom_tree_canonize_ptr_ (decl, offset,
9200                                  TREE_OPERAND (t, 0));
9201
9202       return;
9203
9204     case CONVERT_EXPR:
9205     case NOP_EXPR:
9206     case MODIFY_EXPR:
9207     case NON_LVALUE_EXPR:
9208     case RESULT_DECL:
9209     case FIELD_DECL:
9210     case COND_EXPR:             /* More cases than we can handle. */
9211     case SAVE_EXPR:
9212     case REFERENCE_EXPR:
9213     case PREDECREMENT_EXPR:
9214     case PREINCREMENT_EXPR:
9215     case POSTDECREMENT_EXPR:
9216     case POSTINCREMENT_EXPR:
9217     case CALL_EXPR:
9218     default:
9219       *decl = error_mark_node;
9220       return;
9221     }
9222 }
9223 #endif
9224
9225 /* Do divide operation appropriate to type of operands.  */
9226
9227 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9228 static tree
9229 ffecom_tree_divide_ (tree tree_type, tree left, tree right,
9230                      tree dest_tree, ffebld dest, bool *dest_used,
9231                      tree hook)
9232 {
9233   if ((left == error_mark_node)
9234       || (right == error_mark_node))
9235     return error_mark_node;
9236
9237   switch (TREE_CODE (tree_type))
9238     {
9239     case INTEGER_TYPE:
9240       return ffecom_2 (TRUNC_DIV_EXPR, tree_type,
9241                        left,
9242                        right);
9243
9244     case COMPLEX_TYPE:
9245       if (! optimize_size)
9246         return ffecom_2 (RDIV_EXPR, tree_type,
9247                          left,
9248                          right);
9249       {
9250         ffecomGfrt ix;
9251
9252         if (TREE_TYPE (tree_type)
9253             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9254           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9255         else
9256           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9257
9258         left = ffecom_1 (ADDR_EXPR,
9259                          build_pointer_type (TREE_TYPE (left)),
9260                          left);
9261         left = build_tree_list (NULL_TREE, left);
9262         right = ffecom_1 (ADDR_EXPR,
9263                           build_pointer_type (TREE_TYPE (right)),
9264                           right);
9265         right = build_tree_list (NULL_TREE, right);
9266         TREE_CHAIN (left) = right;
9267
9268         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9269                              ffecom_gfrt_kindtype (ix),
9270                              ffe_is_f2c_library (),
9271                              tree_type,
9272                              left,
9273                              dest_tree, dest, dest_used,
9274                              NULL_TREE, TRUE, hook);
9275       }
9276       break;
9277
9278     case RECORD_TYPE:
9279       {
9280         ffecomGfrt ix;
9281
9282         if (TREE_TYPE (TYPE_FIELDS (tree_type))
9283             == ffecom_tree_type [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1])
9284           ix = FFECOM_gfrtDIV_CC;       /* Overlapping result okay. */
9285         else
9286           ix = FFECOM_gfrtDIV_ZZ;       /* Overlapping result okay. */
9287
9288         left = ffecom_1 (ADDR_EXPR,
9289                          build_pointer_type (TREE_TYPE (left)),
9290                          left);
9291         left = build_tree_list (NULL_TREE, left);
9292         right = ffecom_1 (ADDR_EXPR,
9293                           build_pointer_type (TREE_TYPE (right)),
9294                           right);
9295         right = build_tree_list (NULL_TREE, right);
9296         TREE_CHAIN (left) = right;
9297
9298         return ffecom_call_ (ffecom_gfrt_tree_ (ix),
9299                              ffecom_gfrt_kindtype (ix),
9300                              ffe_is_f2c_library (),
9301                              tree_type,
9302                              left,
9303                              dest_tree, dest, dest_used,
9304                              NULL_TREE, TRUE, hook);
9305       }
9306       break;
9307
9308     default:
9309       return ffecom_2 (RDIV_EXPR, tree_type,
9310                        left,
9311                        right);
9312     }
9313 }
9314
9315 #endif
9316 /* Build type info for non-dummy variable.  */
9317
9318 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9319 static tree
9320 ffecom_type_localvar_ (ffesymbol s, ffeinfoBasictype bt,
9321                        ffeinfoKindtype kt)
9322 {
9323   tree type;
9324   ffebld dl;
9325   ffebld dim;
9326   tree lowt;
9327   tree hight;
9328
9329   type = ffecom_tree_type[bt][kt];
9330   if (bt == FFEINFO_basictypeCHARACTER)
9331     {
9332       hight = build_int_2 (ffesymbol_size (s), 0);
9333       TREE_TYPE (hight) = ffecom_f2c_ftnlen_type_node;
9334
9335       type
9336         = build_array_type
9337           (type,
9338            build_range_type (ffecom_f2c_ftnlen_type_node,
9339                              ffecom_f2c_ftnlen_one_node,
9340                              hight));
9341       type = ffecom_check_size_overflow_ (s, type, FALSE);
9342     }
9343
9344   for (dl = ffesymbol_dims (s); dl != NULL; dl = ffebld_trail (dl))
9345     {
9346       if (type == error_mark_node)
9347         break;
9348
9349       dim = ffebld_head (dl);
9350       assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
9351
9352       if (ffebld_left (dim) == NULL)
9353         lowt = integer_one_node;
9354       else
9355         lowt = ffecom_expr (ffebld_left (dim));
9356
9357       if (TREE_CODE (lowt) != INTEGER_CST)
9358         lowt = variable_size (lowt);
9359
9360       assert (ffebld_right (dim) != NULL);
9361       hight = ffecom_expr (ffebld_right (dim));
9362
9363       if (TREE_CODE (hight) != INTEGER_CST)
9364         hight = variable_size (hight);
9365
9366       type = build_array_type (type,
9367                                build_range_type (ffecom_integer_type_node,
9368                                                  lowt, hight));
9369       type = ffecom_check_size_overflow_ (s, type, FALSE);
9370     }
9371
9372   return type;
9373 }
9374
9375 #endif
9376 /* Build Namelist type.  */
9377
9378 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9379 static tree
9380 ffecom_type_namelist_ ()
9381 {
9382   static tree type = NULL_TREE;
9383
9384   if (type == NULL_TREE)
9385     {
9386       static tree namefield, varsfield, nvarsfield;
9387       tree vardesctype;
9388
9389       vardesctype = ffecom_type_vardesc_ ();
9390
9391       type = make_node (RECORD_TYPE);
9392
9393       vardesctype = build_pointer_type (build_pointer_type (vardesctype));
9394
9395       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9396                                      string_type_node);
9397       varsfield = ffecom_decl_field (type, namefield, "vars", vardesctype);
9398       nvarsfield = ffecom_decl_field (type, varsfield, "nvars",
9399                                       integer_type_node);
9400
9401       TYPE_FIELDS (type) = namefield;
9402       layout_type (type);
9403
9404       ggc_add_tree_root (&type, 1);
9405     }
9406
9407   return type;
9408 }
9409
9410 #endif
9411
9412 /* Build Vardesc type.  */
9413
9414 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9415 static tree
9416 ffecom_type_vardesc_ ()
9417 {
9418   static tree type = NULL_TREE;
9419   static tree namefield, addrfield, dimsfield, typefield;
9420
9421   if (type == NULL_TREE)
9422     {
9423       type = make_node (RECORD_TYPE);
9424
9425       namefield = ffecom_decl_field (type, NULL_TREE, "name",
9426                                      string_type_node);
9427       addrfield = ffecom_decl_field (type, namefield, "addr",
9428                                      string_type_node);
9429       dimsfield = ffecom_decl_field (type, addrfield, "dims",
9430                                      ffecom_f2c_ptr_to_ftnlen_type_node);
9431       typefield = ffecom_decl_field (type, dimsfield, "type",
9432                                      integer_type_node);
9433
9434       TYPE_FIELDS (type) = namefield;
9435       layout_type (type);
9436
9437       ggc_add_tree_root (&type, 1);
9438     }
9439
9440   return type;
9441 }
9442
9443 #endif
9444
9445 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9446 static tree
9447 ffecom_vardesc_ (ffebld expr)
9448 {
9449   ffesymbol s;
9450
9451   assert (ffebld_op (expr) == FFEBLD_opSYMTER);
9452   s = ffebld_symter (expr);
9453
9454   if (ffesymbol_hook (s).vardesc_tree == NULL_TREE)
9455     {
9456       int i;
9457       tree vardesctype = ffecom_type_vardesc_ ();
9458       tree var;
9459       tree nameinit;
9460       tree dimsinit;
9461       tree addrinit;
9462       tree typeinit;
9463       tree field;
9464       tree varinits;
9465       static int mynumber = 0;
9466
9467       var = build_decl (VAR_DECL,
9468                         ffecom_get_invented_identifier ("__g77_vardesc_%d",
9469                                                         mynumber++),
9470                         vardesctype);
9471       TREE_STATIC (var) = 1;
9472       DECL_INITIAL (var) = error_mark_node;
9473
9474       var = start_decl (var, FALSE);
9475
9476       /* Process inits.  */
9477
9478       nameinit = ffecom_build_f2c_string_ ((i = strlen (ffesymbol_text (s)))
9479                                            + 1,
9480                                            ffesymbol_text (s));
9481       TREE_TYPE (nameinit)
9482         = build_type_variant
9483         (build_array_type
9484          (char_type_node,
9485           build_range_type (integer_type_node,
9486                             integer_one_node,
9487                             build_int_2 (i, 0))),
9488          1, 0);
9489       TREE_CONSTANT (nameinit) = 1;
9490       TREE_STATIC (nameinit) = 1;
9491       nameinit = ffecom_1 (ADDR_EXPR,
9492                            build_pointer_type (TREE_TYPE (nameinit)),
9493                            nameinit);
9494
9495       addrinit = ffecom_arg_ptr_to_expr (expr, &typeinit);
9496
9497       dimsinit = ffecom_vardesc_dims_ (s);
9498
9499       if (typeinit == NULL_TREE)
9500         {
9501           ffeinfoBasictype bt = ffesymbol_basictype (s);
9502           ffeinfoKindtype kt = ffesymbol_kindtype (s);
9503           int tc = ffecom_f2c_typecode (bt, kt);
9504
9505           assert (tc != -1);
9506           typeinit = build_int_2 (tc, (tc < 0) ? -1 : 0);
9507         }
9508       else
9509         typeinit = ffecom_1 (NEGATE_EXPR, TREE_TYPE (typeinit), typeinit);
9510
9511       varinits = build_tree_list ((field = TYPE_FIELDS (vardesctype)),
9512                                   nameinit);
9513       TREE_CHAIN (varinits) = build_tree_list ((field = TREE_CHAIN (field)),
9514                                                addrinit);
9515       TREE_CHAIN (TREE_CHAIN (varinits))
9516         = build_tree_list ((field = TREE_CHAIN (field)), dimsinit);
9517       TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (varinits)))
9518         = build_tree_list ((field = TREE_CHAIN (field)), typeinit);
9519
9520       varinits = build (CONSTRUCTOR, vardesctype, NULL_TREE, varinits);
9521       TREE_CONSTANT (varinits) = 1;
9522       TREE_STATIC (varinits) = 1;
9523
9524       finish_decl (var, varinits, FALSE);
9525
9526       var = ffecom_1 (ADDR_EXPR, build_pointer_type (vardesctype), var);
9527
9528       ffesymbol_hook (s).vardesc_tree = var;
9529     }
9530
9531   return ffesymbol_hook (s).vardesc_tree;
9532 }
9533
9534 #endif
9535 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9536 static tree
9537 ffecom_vardesc_array_ (ffesymbol s)
9538 {
9539   ffebld b;
9540   tree list;
9541   tree item = NULL_TREE;
9542   tree var;
9543   int i;
9544   static int mynumber = 0;
9545
9546   for (i = 0, list = NULL_TREE, b = ffesymbol_namelist (s);
9547        b != NULL;
9548        b = ffebld_trail (b), ++i)
9549     {
9550       tree t;
9551
9552       t = ffecom_vardesc_ (ffebld_head (b));
9553
9554       if (list == NULL_TREE)
9555         list = item = build_tree_list (NULL_TREE, t);
9556       else
9557         {
9558           TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9559           item = TREE_CHAIN (item);
9560         }
9561     }
9562
9563   item = build_array_type (build_pointer_type (ffecom_type_vardesc_ ()),
9564                            build_range_type (integer_type_node,
9565                                              integer_one_node,
9566                                              build_int_2 (i, 0)));
9567   list = build (CONSTRUCTOR, item, NULL_TREE, list);
9568   TREE_CONSTANT (list) = 1;
9569   TREE_STATIC (list) = 1;
9570
9571   var = ffecom_get_invented_identifier ("__g77_vardesc_array_%d", mynumber++);
9572   var = build_decl (VAR_DECL, var, item);
9573   TREE_STATIC (var) = 1;
9574   DECL_INITIAL (var) = error_mark_node;
9575   var = start_decl (var, FALSE);
9576   finish_decl (var, list, FALSE);
9577
9578   return var;
9579 }
9580
9581 #endif
9582 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9583 static tree
9584 ffecom_vardesc_dims_ (ffesymbol s)
9585 {
9586   if (ffesymbol_dims (s) == NULL)
9587     return convert (ffecom_f2c_ptr_to_ftnlen_type_node,
9588                     integer_zero_node);
9589
9590   {
9591     ffebld b;
9592     ffebld e;
9593     tree list;
9594     tree backlist;
9595     tree item = NULL_TREE;
9596     tree var;
9597     tree numdim;
9598     tree numelem;
9599     tree baseoff = NULL_TREE;
9600     static int mynumber = 0;
9601
9602     numdim = build_int_2 ((int) ffesymbol_rank (s), 0);
9603     TREE_TYPE (numdim) = ffecom_f2c_ftnlen_type_node;
9604
9605     numelem = ffecom_expr (ffesymbol_arraysize (s));
9606     TREE_TYPE (numelem) = ffecom_f2c_ftnlen_type_node;
9607
9608     list = NULL_TREE;
9609     backlist = NULL_TREE;
9610     for (b = ffesymbol_dims (s), e = ffesymbol_extents (s);
9611          b != NULL;
9612          b = ffebld_trail (b), e = ffebld_trail (e))
9613       {
9614         tree t;
9615         tree low;
9616         tree back;
9617
9618         if (ffebld_trail (b) == NULL)
9619           t = NULL_TREE;
9620         else
9621           {
9622             t = convert (ffecom_f2c_ftnlen_type_node,
9623                          ffecom_expr (ffebld_head (e)));
9624
9625             if (list == NULL_TREE)
9626               list = item = build_tree_list (NULL_TREE, t);
9627             else
9628               {
9629                 TREE_CHAIN (item) = build_tree_list (NULL_TREE, t);
9630                 item = TREE_CHAIN (item);
9631               }
9632           }
9633
9634         if (ffebld_left (ffebld_head (b)) == NULL)
9635           low = ffecom_integer_one_node;
9636         else
9637           low = ffecom_expr (ffebld_left (ffebld_head (b)));
9638         low = convert (ffecom_f2c_ftnlen_type_node, low);
9639
9640         back = build_tree_list (low, t);
9641         TREE_CHAIN (back) = backlist;
9642         backlist = back;
9643       }
9644
9645     for (item = backlist; item != NULL_TREE; item = TREE_CHAIN (item))
9646       {
9647         if (TREE_VALUE (item) == NULL_TREE)
9648           baseoff = TREE_PURPOSE (item);
9649         else
9650           baseoff = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
9651                               TREE_PURPOSE (item),
9652                               ffecom_2 (MULT_EXPR,
9653                                         ffecom_f2c_ftnlen_type_node,
9654                                         TREE_VALUE (item),
9655                                         baseoff));
9656       }
9657
9658     /* backlist now dead, along with all TREE_PURPOSEs on it.  */
9659
9660     baseoff = build_tree_list (NULL_TREE, baseoff);
9661     TREE_CHAIN (baseoff) = list;
9662
9663     numelem = build_tree_list (NULL_TREE, numelem);
9664     TREE_CHAIN (numelem) = baseoff;
9665
9666     numdim = build_tree_list (NULL_TREE, numdim);
9667     TREE_CHAIN (numdim) = numelem;
9668
9669     item = build_array_type (ffecom_f2c_ftnlen_type_node,
9670                              build_range_type (integer_type_node,
9671                                                integer_zero_node,
9672                                                build_int_2
9673                                                ((int) ffesymbol_rank (s)
9674                                                 + 2, 0)));
9675     list = build (CONSTRUCTOR, item, NULL_TREE, numdim);
9676     TREE_CONSTANT (list) = 1;
9677     TREE_STATIC (list) = 1;
9678
9679     var = ffecom_get_invented_identifier ("__g77_dims_%d", mynumber++);
9680     var = build_decl (VAR_DECL, var, item);
9681     TREE_STATIC (var) = 1;
9682     DECL_INITIAL (var) = error_mark_node;
9683     var = start_decl (var, FALSE);
9684     finish_decl (var, list, FALSE);
9685
9686     var = ffecom_1 (ADDR_EXPR, build_pointer_type (item), var);
9687
9688     return var;
9689   }
9690 }
9691
9692 #endif
9693 /* Essentially does a "fold (build1 (code, type, node))" while checking
9694    for certain housekeeping things.
9695
9696    NOTE: for building an ADDR_EXPR around a FUNCTION_DECL, use
9697    ffecom_1_fn instead.  */
9698
9699 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9700 tree
9701 ffecom_1 (enum tree_code code, tree type, tree node)
9702 {
9703   tree item;
9704
9705   if ((node == error_mark_node)
9706       || (type == error_mark_node))
9707     return error_mark_node;
9708
9709   if (code == ADDR_EXPR)
9710     {
9711       if (!mark_addressable (node))
9712         assert ("can't mark_addressable this node!" == NULL);
9713     }
9714
9715   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9716     {
9717       tree realtype;
9718
9719     case REALPART_EXPR:
9720       item = build (COMPONENT_REF, type, node, TYPE_FIELDS (TREE_TYPE (node)));
9721       break;
9722
9723     case IMAGPART_EXPR:
9724       item = build (COMPONENT_REF, type, node, TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (node))));
9725       break;
9726
9727
9728     case NEGATE_EXPR:
9729       if (TREE_CODE (type) != RECORD_TYPE)
9730         {
9731           item = build1 (code, type, node);
9732           break;
9733         }
9734       node = ffecom_stabilize_aggregate_ (node);
9735       realtype = TREE_TYPE (TYPE_FIELDS (type));
9736       item =
9737         ffecom_2 (COMPLEX_EXPR, type,
9738                   ffecom_1 (NEGATE_EXPR, realtype,
9739                             ffecom_1 (REALPART_EXPR, realtype,
9740                                       node)),
9741                   ffecom_1 (NEGATE_EXPR, realtype,
9742                             ffecom_1 (IMAGPART_EXPR, realtype,
9743                                       node)));
9744       break;
9745
9746     default:
9747       item = build1 (code, type, node);
9748       break;
9749     }
9750
9751   if (TREE_SIDE_EFFECTS (node))
9752     TREE_SIDE_EFFECTS (item) = 1;
9753   if ((code == ADDR_EXPR) && staticp (node))
9754     TREE_CONSTANT (item) = 1;
9755   return fold (item);
9756 }
9757 #endif
9758
9759 /* Like ffecom_1 (ADDR_EXPR, TREE_TYPE (node), node), except
9760    handles TREE_CODE (node) == FUNCTION_DECL.  In particular,
9761    does not set TREE_ADDRESSABLE (because calling an inline
9762    function does not mean the function needs to be separately
9763    compiled).  */
9764
9765 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9766 tree
9767 ffecom_1_fn (tree node)
9768 {
9769   tree item;
9770   tree type;
9771
9772   if (node == error_mark_node)
9773     return error_mark_node;
9774
9775   type = build_type_variant (TREE_TYPE (node),
9776                              TREE_READONLY (node),
9777                              TREE_THIS_VOLATILE (node));
9778   item = build1 (ADDR_EXPR,
9779                  build_pointer_type (type), node);
9780   if (TREE_SIDE_EFFECTS (node))
9781     TREE_SIDE_EFFECTS (item) = 1;
9782   if (staticp (node))
9783     TREE_CONSTANT (item) = 1;
9784   return fold (item);
9785 }
9786 #endif
9787
9788 /* Essentially does a "fold (build (code, type, node1, node2))" while
9789    checking for certain housekeeping things.  */
9790
9791 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9792 tree
9793 ffecom_2 (enum tree_code code, tree type, tree node1,
9794           tree node2)
9795 {
9796   tree item;
9797
9798   if ((node1 == error_mark_node)
9799       || (node2 == error_mark_node)
9800       || (type == error_mark_node))
9801     return error_mark_node;
9802
9803   switch (ffe_is_emulate_complex () ? code : NOP_EXPR)
9804     {
9805       tree a, b, c, d, realtype;
9806
9807     case CONJ_EXPR:
9808       assert ("no CONJ_EXPR support yet" == NULL);
9809       return error_mark_node;
9810
9811     case COMPLEX_EXPR:
9812       item = build_tree_list (TYPE_FIELDS (type), node1);
9813       TREE_CHAIN (item) = build_tree_list (TREE_CHAIN (TYPE_FIELDS (type)), node2);
9814       item = build (CONSTRUCTOR, type, NULL_TREE, item);
9815       break;
9816
9817     case PLUS_EXPR:
9818       if (TREE_CODE (type) != RECORD_TYPE)
9819         {
9820           item = build (code, type, node1, node2);
9821           break;
9822         }
9823       node1 = ffecom_stabilize_aggregate_ (node1);
9824       node2 = ffecom_stabilize_aggregate_ (node2);
9825       realtype = TREE_TYPE (TYPE_FIELDS (type));
9826       item =
9827         ffecom_2 (COMPLEX_EXPR, type,
9828                   ffecom_2 (PLUS_EXPR, realtype,
9829                             ffecom_1 (REALPART_EXPR, realtype,
9830                                       node1),
9831                             ffecom_1 (REALPART_EXPR, realtype,
9832                                       node2)),
9833                   ffecom_2 (PLUS_EXPR, realtype,
9834                             ffecom_1 (IMAGPART_EXPR, realtype,
9835                                       node1),
9836                             ffecom_1 (IMAGPART_EXPR, realtype,
9837                                       node2)));
9838       break;
9839
9840     case MINUS_EXPR:
9841       if (TREE_CODE (type) != RECORD_TYPE)
9842         {
9843           item = build (code, type, node1, node2);
9844           break;
9845         }
9846       node1 = ffecom_stabilize_aggregate_ (node1);
9847       node2 = ffecom_stabilize_aggregate_ (node2);
9848       realtype = TREE_TYPE (TYPE_FIELDS (type));
9849       item =
9850         ffecom_2 (COMPLEX_EXPR, type,
9851                   ffecom_2 (MINUS_EXPR, realtype,
9852                             ffecom_1 (REALPART_EXPR, realtype,
9853                                       node1),
9854                             ffecom_1 (REALPART_EXPR, realtype,
9855                                       node2)),
9856                   ffecom_2 (MINUS_EXPR, realtype,
9857                             ffecom_1 (IMAGPART_EXPR, realtype,
9858                                       node1),
9859                             ffecom_1 (IMAGPART_EXPR, realtype,
9860                                       node2)));
9861       break;
9862
9863     case MULT_EXPR:
9864       if (TREE_CODE (type) != RECORD_TYPE)
9865         {
9866           item = build (code, type, node1, node2);
9867           break;
9868         }
9869       node1 = ffecom_stabilize_aggregate_ (node1);
9870       node2 = ffecom_stabilize_aggregate_ (node2);
9871       realtype = TREE_TYPE (TYPE_FIELDS (type));
9872       a = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9873                                node1));
9874       b = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9875                                node1));
9876       c = save_expr (ffecom_1 (REALPART_EXPR, realtype,
9877                                node2));
9878       d = save_expr (ffecom_1 (IMAGPART_EXPR, realtype,
9879                                node2));
9880       item =
9881         ffecom_2 (COMPLEX_EXPR, type,
9882                   ffecom_2 (MINUS_EXPR, realtype,
9883                             ffecom_2 (MULT_EXPR, realtype,
9884                                       a,
9885                                       c),
9886                             ffecom_2 (MULT_EXPR, realtype,
9887                                       b,
9888                                       d)),
9889                   ffecom_2 (PLUS_EXPR, realtype,
9890                             ffecom_2 (MULT_EXPR, realtype,
9891                                       a,
9892                                       d),
9893                             ffecom_2 (MULT_EXPR, realtype,
9894                                       c,
9895                                       b)));
9896       break;
9897
9898     case EQ_EXPR:
9899       if ((TREE_CODE (node1) != RECORD_TYPE)
9900           && (TREE_CODE (node2) != RECORD_TYPE))
9901         {
9902           item = build (code, type, node1, node2);
9903           break;
9904         }
9905       assert (TREE_CODE (node1) == RECORD_TYPE);
9906       assert (TREE_CODE (node2) == RECORD_TYPE);
9907       node1 = ffecom_stabilize_aggregate_ (node1);
9908       node2 = ffecom_stabilize_aggregate_ (node2);
9909       realtype = TREE_TYPE (TYPE_FIELDS (type));
9910       item =
9911         ffecom_2 (TRUTH_ANDIF_EXPR, type,
9912                   ffecom_2 (code, type,
9913                             ffecom_1 (REALPART_EXPR, realtype,
9914                                       node1),
9915                             ffecom_1 (REALPART_EXPR, realtype,
9916                                       node2)),
9917                   ffecom_2 (code, type,
9918                             ffecom_1 (IMAGPART_EXPR, realtype,
9919                                       node1),
9920                             ffecom_1 (IMAGPART_EXPR, realtype,
9921                                       node2)));
9922       break;
9923
9924     case NE_EXPR:
9925       if ((TREE_CODE (node1) != RECORD_TYPE)
9926           && (TREE_CODE (node2) != RECORD_TYPE))
9927         {
9928           item = build (code, type, node1, node2);
9929           break;
9930         }
9931       assert (TREE_CODE (node1) == RECORD_TYPE);
9932       assert (TREE_CODE (node2) == RECORD_TYPE);
9933       node1 = ffecom_stabilize_aggregate_ (node1);
9934       node2 = ffecom_stabilize_aggregate_ (node2);
9935       realtype = TREE_TYPE (TYPE_FIELDS (type));
9936       item =
9937         ffecom_2 (TRUTH_ORIF_EXPR, type,
9938                   ffecom_2 (code, type,
9939                             ffecom_1 (REALPART_EXPR, realtype,
9940                                       node1),
9941                             ffecom_1 (REALPART_EXPR, realtype,
9942                                       node2)),
9943                   ffecom_2 (code, type,
9944                             ffecom_1 (IMAGPART_EXPR, realtype,
9945                                       node1),
9946                             ffecom_1 (IMAGPART_EXPR, realtype,
9947                                       node2)));
9948       break;
9949
9950     default:
9951       item = build (code, type, node1, node2);
9952       break;
9953     }
9954
9955   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2))
9956     TREE_SIDE_EFFECTS (item) = 1;
9957   return fold (item);
9958 }
9959
9960 #endif
9961 /* ffecom_2pass_advise_entrypoint -- Advise that there's this entrypoint
9962
9963    ffesymbol s;  // the ENTRY point itself
9964    if (ffecom_2pass_advise_entrypoint(s))
9965        // the ENTRY point has been accepted
9966
9967    Does whatever compiler needs to do when it learns about the entrypoint,
9968    like determine the return type of the master function, count the
9969    number of entrypoints, etc.  Returns FALSE if the return type is
9970    not compatible with the return type(s) of other entrypoint(s).
9971
9972    NOTE: for every call to this fn that returns TRUE, _do_entrypoint must
9973    later (after _finish_progunit) be called with the same entrypoint(s)
9974    as passed to this fn for which TRUE was returned.
9975
9976    03-Jan-92  JCB  2.0
9977       Return FALSE if the return type conflicts with previous entrypoints.  */
9978
9979 #if FFECOM_targetCURRENT == FFECOM_targetGCC
9980 bool
9981 ffecom_2pass_advise_entrypoint (ffesymbol entry)
9982 {
9983   ffebld list;                  /* opITEM. */
9984   ffebld mlist;                 /* opITEM. */
9985   ffebld plist;                 /* opITEM. */
9986   ffebld arg;                   /* ffebld_head(opITEM). */
9987   ffebld item;                  /* opITEM. */
9988   ffesymbol s;                  /* ffebld_symter(arg). */
9989   ffeinfoBasictype bt = ffesymbol_basictype (entry);
9990   ffeinfoKindtype kt = ffesymbol_kindtype (entry);
9991   ffetargetCharacterSize size = ffesymbol_size (entry);
9992   bool ok;
9993
9994   if (ffecom_num_entrypoints_ == 0)
9995     {                           /* First entrypoint, make list of main
9996                                    arglist's dummies. */
9997       assert (ffecom_primary_entry_ != NULL);
9998
9999       ffecom_master_bt_ = ffesymbol_basictype (ffecom_primary_entry_);
10000       ffecom_master_kt_ = ffesymbol_kindtype (ffecom_primary_entry_);
10001       ffecom_master_size_ = ffesymbol_size (ffecom_primary_entry_);
10002
10003       for (plist = NULL, list = ffesymbol_dummyargs (ffecom_primary_entry_);
10004            list != NULL;
10005            list = ffebld_trail (list))
10006         {
10007           arg = ffebld_head (list);
10008           if (ffebld_op (arg) != FFEBLD_opSYMTER)
10009             continue;           /* Alternate return or some such thing. */
10010           item = ffebld_new_item (arg, NULL);
10011           if (plist == NULL)
10012             ffecom_master_arglist_ = item;
10013           else
10014             ffebld_set_trail (plist, item);
10015           plist = item;
10016         }
10017     }
10018
10019   /* If necessary, scan entry arglist for alternate returns.  Do this scan
10020      apparently redundantly (it's done below to UNIONize the arglists) so
10021      that we don't complain about RETURN 1 if an offending ENTRY is the only
10022      one with an alternate return.  */
10023
10024   if (!ffecom_is_altreturning_)
10025     {
10026       for (list = ffesymbol_dummyargs (entry);
10027            list != NULL;
10028            list = ffebld_trail (list))
10029         {
10030           arg = ffebld_head (list);
10031           if (ffebld_op (arg) == FFEBLD_opSTAR)
10032             {
10033               ffecom_is_altreturning_ = TRUE;
10034               break;
10035             }
10036         }
10037     }
10038
10039   /* Now check type compatibility. */
10040
10041   switch (ffecom_master_bt_)
10042     {
10043     case FFEINFO_basictypeNONE:
10044       ok = (bt != FFEINFO_basictypeCHARACTER);
10045       break;
10046
10047     case FFEINFO_basictypeCHARACTER:
10048       ok
10049         = (bt == FFEINFO_basictypeCHARACTER)
10050         && (kt == ffecom_master_kt_)
10051         && (size == ffecom_master_size_);
10052       break;
10053
10054     case FFEINFO_basictypeANY:
10055       return FALSE;             /* Just don't bother. */
10056
10057     default:
10058       if (bt == FFEINFO_basictypeCHARACTER)
10059         {
10060           ok = FALSE;
10061           break;
10062         }
10063       ok = TRUE;
10064       if ((bt != ffecom_master_bt_) || (kt != ffecom_master_kt_))
10065         {
10066           ffecom_master_bt_ = FFEINFO_basictypeNONE;
10067           ffecom_master_kt_ = FFEINFO_kindtypeNONE;
10068         }
10069       break;
10070     }
10071
10072   if (!ok)
10073     {
10074       ffebad_start (FFEBAD_ENTRY_CONFLICTS);
10075       ffest_ffebad_here_current_stmt (0);
10076       ffebad_finish ();
10077       return FALSE;             /* Can't handle entrypoint. */
10078     }
10079
10080   /* Entrypoint type compatible with previous types. */
10081
10082   ++ffecom_num_entrypoints_;
10083
10084   /* Master-arg-list = UNION(Master-arg-list,entry-arg-list). */
10085
10086   for (list = ffesymbol_dummyargs (entry);
10087        list != NULL;
10088        list = ffebld_trail (list))
10089     {
10090       arg = ffebld_head (list);
10091       if (ffebld_op (arg) != FFEBLD_opSYMTER)
10092         continue;               /* Alternate return or some such thing. */
10093       s = ffebld_symter (arg);
10094       for (plist = NULL, mlist = ffecom_master_arglist_;
10095            mlist != NULL;
10096            plist = mlist, mlist = ffebld_trail (mlist))
10097         {                       /* plist points to previous item for easy
10098                                    appending of arg. */
10099           if (ffebld_symter (ffebld_head (mlist)) == s)
10100             break;              /* Already have this arg in the master list. */
10101         }
10102       if (mlist != NULL)
10103         continue;               /* Already have this arg in the master list. */
10104
10105       /* Append this arg to the master list. */
10106
10107       item = ffebld_new_item (arg, NULL);
10108       if (plist == NULL)
10109         ffecom_master_arglist_ = item;
10110       else
10111         ffebld_set_trail (plist, item);
10112     }
10113
10114   return TRUE;
10115 }
10116
10117 #endif
10118 /* ffecom_2pass_do_entrypoint -- Do compilation of entrypoint
10119
10120    ffesymbol s;  // the ENTRY point itself
10121    ffecom_2pass_do_entrypoint(s);
10122
10123    Does whatever compiler needs to do to make the entrypoint actually
10124    happen.  Must be called for each entrypoint after
10125    ffecom_finish_progunit is called.  */
10126
10127 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10128 void
10129 ffecom_2pass_do_entrypoint (ffesymbol entry)
10130 {
10131   static int mfn_num = 0;
10132   static int ent_num;
10133
10134   if (mfn_num != ffecom_num_fns_)
10135     {                           /* First entrypoint for this program unit. */
10136       ent_num = 1;
10137       mfn_num = ffecom_num_fns_;
10138       ffecom_do_entry_ (ffecom_primary_entry_, 0);
10139     }
10140   else
10141     ++ent_num;
10142
10143   --ffecom_num_entrypoints_;
10144
10145   ffecom_do_entry_ (entry, ent_num);
10146 }
10147
10148 #endif
10149
10150 /* Essentially does a "fold (build (code, type, node1, node2))" while
10151    checking for certain housekeeping things.  Always sets
10152    TREE_SIDE_EFFECTS.  */
10153
10154 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10155 tree
10156 ffecom_2s (enum tree_code code, tree type, tree node1,
10157            tree node2)
10158 {
10159   tree item;
10160
10161   if ((node1 == error_mark_node)
10162       || (node2 == error_mark_node)
10163       || (type == error_mark_node))
10164     return error_mark_node;
10165
10166   item = build (code, type, node1, node2);
10167   TREE_SIDE_EFFECTS (item) = 1;
10168   return fold (item);
10169 }
10170
10171 #endif
10172 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10173    checking for certain housekeeping things.  */
10174
10175 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10176 tree
10177 ffecom_3 (enum tree_code code, tree type, tree node1,
10178           tree node2, tree node3)
10179 {
10180   tree item;
10181
10182   if ((node1 == error_mark_node)
10183       || (node2 == error_mark_node)
10184       || (node3 == error_mark_node)
10185       || (type == error_mark_node))
10186     return error_mark_node;
10187
10188   item = build (code, type, node1, node2, node3);
10189   if (TREE_SIDE_EFFECTS (node1) || TREE_SIDE_EFFECTS (node2)
10190       || (node3 != NULL_TREE && TREE_SIDE_EFFECTS (node3)))
10191     TREE_SIDE_EFFECTS (item) = 1;
10192   return fold (item);
10193 }
10194
10195 #endif
10196 /* Essentially does a "fold (build (code, type, node1, node2, node3))" while
10197    checking for certain housekeeping things.  Always sets
10198    TREE_SIDE_EFFECTS.  */
10199
10200 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10201 tree
10202 ffecom_3s (enum tree_code code, tree type, tree node1,
10203            tree node2, tree node3)
10204 {
10205   tree item;
10206
10207   if ((node1 == error_mark_node)
10208       || (node2 == error_mark_node)
10209       || (node3 == error_mark_node)
10210       || (type == error_mark_node))
10211     return error_mark_node;
10212
10213   item = build (code, type, node1, node2, node3);
10214   TREE_SIDE_EFFECTS (item) = 1;
10215   return fold (item);
10216 }
10217
10218 #endif
10219
10220 /* ffecom_arg_expr -- Transform argument expr into gcc tree
10221
10222    See use by ffecom_list_expr.
10223
10224    If expression is NULL, returns an integer zero tree.  If it is not
10225    a CHARACTER expression, returns whatever ffecom_expr
10226    returns and sets the length return value to NULL_TREE.  Otherwise
10227    generates code to evaluate the character expression, returns the proper
10228    pointer to the result, but does NOT set the length return value to a tree
10229    that specifies the length of the result.  (In other words, the length
10230    variable is always set to NULL_TREE, because a length is never passed.)
10231
10232    21-Dec-91  JCB  1.1
10233       Don't set returned length, since nobody needs it (yet; someday if
10234       we allow CHARACTER*(*) dummies to statement functions, we'll need
10235       it).  */
10236
10237 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10238 tree
10239 ffecom_arg_expr (ffebld expr, tree *length)
10240 {
10241   tree ign;
10242
10243   *length = NULL_TREE;
10244
10245   if (expr == NULL)
10246     return integer_zero_node;
10247
10248   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10249     return ffecom_expr (expr);
10250
10251   return ffecom_arg_ptr_to_expr (expr, &ign);
10252 }
10253
10254 #endif
10255 /* Transform expression into constant argument-pointer-to-expression tree.
10256
10257    If the expression can be transformed into a argument-pointer-to-expression
10258    tree that is constant, that is done, and the tree returned.  Else
10259    NULL_TREE is returned.
10260
10261    That way, a caller can attempt to provide compile-time initialization
10262    of a variable and, if that fails, *then* choose to start a new block
10263    and resort to using temporaries, as appropriate.  */
10264
10265 tree
10266 ffecom_arg_ptr_to_const_expr (ffebld expr, tree *length)
10267 {
10268   if (! expr)
10269     return integer_zero_node;
10270
10271   if (ffebld_op (expr) == FFEBLD_opANY)
10272     {
10273       if (length)
10274         *length = error_mark_node;
10275       return error_mark_node;
10276     }
10277
10278   if (ffebld_arity (expr) == 0
10279       && (ffebld_op (expr) != FFEBLD_opSYMTER
10280           || ffebld_where (expr) == FFEINFO_whereCOMMON
10281           || ffebld_where (expr) == FFEINFO_whereGLOBAL
10282           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10283     {
10284       tree t;
10285
10286       t = ffecom_arg_ptr_to_expr (expr, length);
10287       assert (TREE_CONSTANT (t));
10288       assert (! length || TREE_CONSTANT (*length));
10289       return t;
10290     }
10291
10292   if (length
10293       && ffebld_size (expr) != FFETARGET_charactersizeNONE)
10294     *length = build_int_2 (ffebld_size (expr), 0);
10295   else if (length)
10296     *length = NULL_TREE;
10297   return NULL_TREE;
10298 }
10299
10300 /* ffecom_arg_ptr_to_expr -- Transform argument expr into gcc tree
10301
10302    See use by ffecom_list_ptr_to_expr.
10303
10304    If expression is NULL, returns an integer zero tree.  If it is not
10305    a CHARACTER expression, returns whatever ffecom_ptr_to_expr
10306    returns and sets the length return value to NULL_TREE.  Otherwise
10307    generates code to evaluate the character expression, returns the proper
10308    pointer to the result, AND sets the length return value to a tree that
10309    specifies the length of the result.
10310
10311    If the length argument is NULL, this is a slightly special
10312    case of building a FORMAT expression, that is, an expression that
10313    will be used at run time without regard to length.  For the current
10314    implementation, which uses the libf2c library, this means it is nice
10315    to append a null byte to the end of the expression, where feasible,
10316    to make sure any diagnostic about the FORMAT string terminates at
10317    some useful point.
10318
10319    For now, treat %REF(char-expr) as the same as char-expr with a NULL
10320    length argument.  This might even be seen as a feature, if a null
10321    byte can always be appended.  */
10322
10323 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10324 tree
10325 ffecom_arg_ptr_to_expr (ffebld expr, tree *length)
10326 {
10327   tree item;
10328   tree ign_length;
10329   ffecomConcatList_ catlist;
10330
10331   if (length != NULL)
10332     *length = NULL_TREE;
10333
10334   if (expr == NULL)
10335     return integer_zero_node;
10336
10337   switch (ffebld_op (expr))
10338     {
10339     case FFEBLD_opPERCENT_VAL:
10340       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10341         return ffecom_expr (ffebld_left (expr));
10342       {
10343         tree temp_exp;
10344         tree temp_length;
10345
10346         temp_exp = ffecom_arg_ptr_to_expr (ffebld_left (expr), &temp_length);
10347         if (temp_exp == error_mark_node)
10348           return error_mark_node;
10349
10350         return ffecom_1 (INDIRECT_REF, TREE_TYPE (TREE_TYPE (temp_exp)),
10351                          temp_exp);
10352       }
10353
10354     case FFEBLD_opPERCENT_REF:
10355       if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10356         return ffecom_ptr_to_expr (ffebld_left (expr));
10357       if (length != NULL)
10358         {
10359           ign_length = NULL_TREE;
10360           length = &ign_length;
10361         }
10362       expr = ffebld_left (expr);
10363       break;
10364
10365     case FFEBLD_opPERCENT_DESCR:
10366       switch (ffeinfo_basictype (ffebld_info (expr)))
10367         {
10368 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10369         case FFEINFO_basictypeHOLLERITH:
10370 #endif
10371         case FFEINFO_basictypeCHARACTER:
10372           break;                /* Passed by descriptor anyway. */
10373
10374         default:
10375           item = ffecom_ptr_to_expr (expr);
10376           if (item != error_mark_node)
10377             *length = TYPE_SIZE (TREE_TYPE (TREE_TYPE (item)));
10378           break;
10379         }
10380       break;
10381
10382     default:
10383       break;
10384     }
10385
10386 #ifdef PASS_HOLLERITH_BY_DESCRIPTOR
10387   if ((ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeHOLLERITH)
10388       && (length != NULL))
10389     {                           /* Pass Hollerith by descriptor. */
10390       ffetargetHollerith h;
10391
10392       assert (ffebld_op (expr) == FFEBLD_opCONTER);
10393       h = ffebld_cu_val_hollerith (ffebld_constant_union
10394                                    (ffebld_conter (expr)));
10395       *length
10396         = build_int_2 (h.length, 0);
10397       TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10398     }
10399 #endif
10400
10401   if (ffeinfo_basictype (ffebld_info (expr)) != FFEINFO_basictypeCHARACTER)
10402     return ffecom_ptr_to_expr (expr);
10403
10404   assert (ffeinfo_kindtype (ffebld_info (expr))
10405           == FFEINFO_kindtypeCHARACTER1);
10406
10407   while (ffebld_op (expr) == FFEBLD_opPAREN)
10408     expr = ffebld_left (expr);
10409
10410   catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
10411   switch (ffecom_concat_list_count_ (catlist))
10412     {
10413     case 0:                     /* Shouldn't happen, but in case it does... */
10414       if (length != NULL)
10415         {
10416           *length = ffecom_f2c_ftnlen_zero_node;
10417           TREE_TYPE (*length) = ffecom_f2c_ftnlen_type_node;
10418         }
10419       ffecom_concat_list_kill_ (catlist);
10420       return null_pointer_node;
10421
10422     case 1:                     /* The (fairly) easy case. */
10423       if (length == NULL)
10424         ffecom_char_args_with_null_ (&item, &ign_length,
10425                                      ffecom_concat_list_expr_ (catlist, 0));
10426       else
10427         ffecom_char_args_ (&item, length,
10428                            ffecom_concat_list_expr_ (catlist, 0));
10429       ffecom_concat_list_kill_ (catlist);
10430       assert (item != NULL_TREE);
10431       return item;
10432
10433     default:                    /* Must actually concatenate things. */
10434       break;
10435     }
10436
10437   {
10438     int count = ffecom_concat_list_count_ (catlist);
10439     int i;
10440     tree lengths;
10441     tree items;
10442     tree length_array;
10443     tree item_array;
10444     tree citem;
10445     tree clength;
10446     tree temporary;
10447     tree num;
10448     tree known_length;
10449     ffetargetCharacterSize sz;
10450
10451     sz = ffecom_concat_list_maxlen_ (catlist);
10452     /* ~~Kludge! */
10453     assert (sz != FFETARGET_charactersizeNONE);
10454
10455 #ifdef HOHO
10456     length_array
10457       = lengths
10458       = ffecom_push_tempvar (ffecom_f2c_ftnlen_type_node,
10459                              FFETARGET_charactersizeNONE, count, TRUE);
10460     item_array
10461       = items
10462       = ffecom_push_tempvar (ffecom_f2c_address_type_node,
10463                              FFETARGET_charactersizeNONE, count, TRUE);
10464     temporary = ffecom_push_tempvar (char_type_node,
10465                                      sz, -1, TRUE);
10466 #else
10467     {
10468       tree hook;
10469
10470       hook = ffebld_nonter_hook (expr);
10471       assert (hook);
10472       assert (TREE_CODE (hook) == TREE_VEC);
10473       assert (TREE_VEC_LENGTH (hook) == 3);
10474       length_array = lengths = TREE_VEC_ELT (hook, 0);
10475       item_array = items = TREE_VEC_ELT (hook, 1);
10476       temporary = TREE_VEC_ELT (hook, 2);
10477     }
10478 #endif
10479
10480     known_length = ffecom_f2c_ftnlen_zero_node;
10481
10482     for (i = 0; i < count; ++i)
10483       {
10484         if ((i == count)
10485             && (length == NULL))
10486           ffecom_char_args_with_null_ (&citem, &clength,
10487                                        ffecom_concat_list_expr_ (catlist, i));
10488         else
10489           ffecom_char_args_ (&citem, &clength,
10490                              ffecom_concat_list_expr_ (catlist, i));
10491         if ((citem == error_mark_node)
10492             || (clength == error_mark_node))
10493           {
10494             ffecom_concat_list_kill_ (catlist);
10495             *length = error_mark_node;
10496             return error_mark_node;
10497           }
10498
10499         items
10500           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (items),
10501                       ffecom_modify (void_type_node,
10502                                      ffecom_2 (ARRAY_REF,
10503                      TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (item_array))),
10504                                                item_array,
10505                                                build_int_2 (i, 0)),
10506                                      citem),
10507                       items);
10508         clength = ffecom_save_tree (clength);
10509         if (length != NULL)
10510           known_length
10511             = ffecom_2 (PLUS_EXPR, ffecom_f2c_ftnlen_type_node,
10512                         known_length,
10513                         clength);
10514         lengths
10515           = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (lengths),
10516                       ffecom_modify (void_type_node,
10517                                      ffecom_2 (ARRAY_REF,
10518                    TYPE_MAIN_VARIANT (TREE_TYPE (TREE_TYPE (length_array))),
10519                                                length_array,
10520                                                build_int_2 (i, 0)),
10521                                      clength),
10522                       lengths);
10523       }
10524
10525     temporary = ffecom_1 (ADDR_EXPR,
10526                           build_pointer_type (TREE_TYPE (temporary)),
10527                           temporary);
10528
10529     item = build_tree_list (NULL_TREE, temporary);
10530     TREE_CHAIN (item)
10531       = build_tree_list (NULL_TREE,
10532                          ffecom_1 (ADDR_EXPR,
10533                                    build_pointer_type (TREE_TYPE (items)),
10534                                    items));
10535     TREE_CHAIN (TREE_CHAIN (item))
10536       = build_tree_list (NULL_TREE,
10537                          ffecom_1 (ADDR_EXPR,
10538                                    build_pointer_type (TREE_TYPE (lengths)),
10539                                    lengths));
10540     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item)))
10541       = build_tree_list
10542         (NULL_TREE,
10543          ffecom_1 (ADDR_EXPR, ffecom_f2c_ptr_to_ftnlen_type_node,
10544                    convert (ffecom_f2c_ftnlen_type_node,
10545                             build_int_2 (count, 0))));
10546     num = build_int_2 (sz, 0);
10547     TREE_TYPE (num) = ffecom_f2c_ftnlen_type_node;
10548     TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (TREE_CHAIN (item))))
10549       = build_tree_list (NULL_TREE, num);
10550
10551     item = ffecom_call_gfrt (FFECOM_gfrtCAT, item, NULL_TREE);
10552     TREE_SIDE_EFFECTS (item) = 1;
10553     item = ffecom_2 (COMPOUND_EXPR, TREE_TYPE (temporary),
10554                      item,
10555                      temporary);
10556
10557     if (length != NULL)
10558       *length = known_length;
10559   }
10560
10561   ffecom_concat_list_kill_ (catlist);
10562   assert (item != NULL_TREE);
10563   return item;
10564 }
10565
10566 #endif
10567 /* Generate call to run-time function.
10568
10569    The first arg is the GNU Fortran Run-Time function index, the second
10570    arg is the list of arguments to pass to it.  Returned is the expression
10571    (WITHOUT TREE_SIDE_EFFECTS set!) that makes the call and returns the
10572    result (which may be void).  */
10573
10574 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10575 tree
10576 ffecom_call_gfrt (ffecomGfrt ix, tree args, tree hook)
10577 {
10578   return ffecom_call_ (ffecom_gfrt_tree_ (ix),
10579                        ffecom_gfrt_kindtype (ix),
10580                        ffe_is_f2c_library () && ffecom_gfrt_complex_[ix],
10581                        NULL_TREE, args, NULL_TREE, NULL,
10582                        NULL, NULL_TREE, TRUE, hook);
10583 }
10584 #endif
10585
10586 /* Transform constant-union to tree.  */
10587
10588 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10589 tree
10590 ffecom_constantunion (ffebldConstantUnion *cu, ffeinfoBasictype bt,
10591                       ffeinfoKindtype kt, tree tree_type)
10592 {
10593   tree item;
10594
10595   switch (bt)
10596     {
10597     case FFEINFO_basictypeINTEGER:
10598       {
10599         int val;
10600
10601         switch (kt)
10602           {
10603 #if FFETARGET_okINTEGER1
10604           case FFEINFO_kindtypeINTEGER1:
10605             val = ffebld_cu_val_integer1 (*cu);
10606             break;
10607 #endif
10608
10609 #if FFETARGET_okINTEGER2
10610           case FFEINFO_kindtypeINTEGER2:
10611             val = ffebld_cu_val_integer2 (*cu);
10612             break;
10613 #endif
10614
10615 #if FFETARGET_okINTEGER3
10616           case FFEINFO_kindtypeINTEGER3:
10617             val = ffebld_cu_val_integer3 (*cu);
10618             break;
10619 #endif
10620
10621 #if FFETARGET_okINTEGER4
10622           case FFEINFO_kindtypeINTEGER4:
10623             val = ffebld_cu_val_integer4 (*cu);
10624             break;
10625 #endif
10626
10627           default:
10628             assert ("bad INTEGER constant kind type" == NULL);
10629             /* Fall through. */
10630           case FFEINFO_kindtypeANY:
10631             return error_mark_node;
10632           }
10633         item = build_int_2 (val, (val < 0) ? -1 : 0);
10634         TREE_TYPE (item) = tree_type;
10635       }
10636       break;
10637
10638     case FFEINFO_basictypeLOGICAL:
10639       {
10640         int val;
10641
10642         switch (kt)
10643           {
10644 #if FFETARGET_okLOGICAL1
10645           case FFEINFO_kindtypeLOGICAL1:
10646             val = ffebld_cu_val_logical1 (*cu);
10647             break;
10648 #endif
10649
10650 #if FFETARGET_okLOGICAL2
10651           case FFEINFO_kindtypeLOGICAL2:
10652             val = ffebld_cu_val_logical2 (*cu);
10653             break;
10654 #endif
10655
10656 #if FFETARGET_okLOGICAL3
10657           case FFEINFO_kindtypeLOGICAL3:
10658             val = ffebld_cu_val_logical3 (*cu);
10659             break;
10660 #endif
10661
10662 #if FFETARGET_okLOGICAL4
10663           case FFEINFO_kindtypeLOGICAL4:
10664             val = ffebld_cu_val_logical4 (*cu);
10665             break;
10666 #endif
10667
10668           default:
10669             assert ("bad LOGICAL constant kind type" == NULL);
10670             /* Fall through. */
10671           case FFEINFO_kindtypeANY:
10672             return error_mark_node;
10673           }
10674         item = build_int_2 (val, (val < 0) ? -1 : 0);
10675         TREE_TYPE (item) = tree_type;
10676       }
10677       break;
10678
10679     case FFEINFO_basictypeREAL:
10680       {
10681         REAL_VALUE_TYPE val;
10682
10683         switch (kt)
10684           {
10685 #if FFETARGET_okREAL1
10686           case FFEINFO_kindtypeREAL1:
10687             val = ffetarget_value_real1 (ffebld_cu_val_real1 (*cu));
10688             break;
10689 #endif
10690
10691 #if FFETARGET_okREAL2
10692           case FFEINFO_kindtypeREAL2:
10693             val = ffetarget_value_real2 (ffebld_cu_val_real2 (*cu));
10694             break;
10695 #endif
10696
10697 #if FFETARGET_okREAL3
10698           case FFEINFO_kindtypeREAL3:
10699             val = ffetarget_value_real3 (ffebld_cu_val_real3 (*cu));
10700             break;
10701 #endif
10702
10703 #if FFETARGET_okREAL4
10704           case FFEINFO_kindtypeREAL4:
10705             val = ffetarget_value_real4 (ffebld_cu_val_real4 (*cu));
10706             break;
10707 #endif
10708
10709           default:
10710             assert ("bad REAL constant kind type" == NULL);
10711             /* Fall through. */
10712           case FFEINFO_kindtypeANY:
10713             return error_mark_node;
10714           }
10715         item = build_real (tree_type, val);
10716       }
10717       break;
10718
10719     case FFEINFO_basictypeCOMPLEX:
10720       {
10721         REAL_VALUE_TYPE real;
10722         REAL_VALUE_TYPE imag;
10723         tree el_type = ffecom_tree_type[FFEINFO_basictypeREAL][kt];
10724
10725         switch (kt)
10726           {
10727 #if FFETARGET_okCOMPLEX1
10728           case FFEINFO_kindtypeREAL1:
10729             real = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).real);
10730             imag = ffetarget_value_real1 (ffebld_cu_val_complex1 (*cu).imaginary);
10731             break;
10732 #endif
10733
10734 #if FFETARGET_okCOMPLEX2
10735           case FFEINFO_kindtypeREAL2:
10736             real = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).real);
10737             imag = ffetarget_value_real2 (ffebld_cu_val_complex2 (*cu).imaginary);
10738             break;
10739 #endif
10740
10741 #if FFETARGET_okCOMPLEX3
10742           case FFEINFO_kindtypeREAL3:
10743             real = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).real);
10744             imag = ffetarget_value_real3 (ffebld_cu_val_complex3 (*cu).imaginary);
10745             break;
10746 #endif
10747
10748 #if FFETARGET_okCOMPLEX4
10749           case FFEINFO_kindtypeREAL4:
10750             real = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).real);
10751             imag = ffetarget_value_real4 (ffebld_cu_val_complex4 (*cu).imaginary);
10752             break;
10753 #endif
10754
10755           default:
10756             assert ("bad REAL constant kind type" == NULL);
10757             /* Fall through. */
10758           case FFEINFO_kindtypeANY:
10759             return error_mark_node;
10760           }
10761         item = ffecom_build_complex_constant_ (tree_type,
10762                                                build_real (el_type, real),
10763                                                build_real (el_type, imag));
10764       }
10765       break;
10766
10767     case FFEINFO_basictypeCHARACTER:
10768       {                         /* Happens only in DATA and similar contexts. */
10769         ffetargetCharacter1 val;
10770
10771         switch (kt)
10772           {
10773 #if FFETARGET_okCHARACTER1
10774           case FFEINFO_kindtypeLOGICAL1:
10775             val = ffebld_cu_val_character1 (*cu);
10776             break;
10777 #endif
10778
10779           default:
10780             assert ("bad CHARACTER constant kind type" == NULL);
10781             /* Fall through. */
10782           case FFEINFO_kindtypeANY:
10783             return error_mark_node;
10784           }
10785         item = build_string (ffetarget_length_character1 (val),
10786                              ffetarget_text_character1 (val));
10787         TREE_TYPE (item)
10788           = build_type_variant (build_array_type (char_type_node,
10789                                                   build_range_type
10790                                                   (integer_type_node,
10791                                                    integer_one_node,
10792                                                    build_int_2
10793                                                 (ffetarget_length_character1
10794                                                  (val), 0))),
10795                                 1, 0);
10796       }
10797       break;
10798
10799     case FFEINFO_basictypeHOLLERITH:
10800       {
10801         ffetargetHollerith h;
10802
10803         h = ffebld_cu_val_hollerith (*cu);
10804
10805         /* If not at least as wide as default INTEGER, widen it.  */
10806         if (h.length >= FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE)
10807           item = build_string (h.length, h.text);
10808         else
10809           {
10810             char str[FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE];
10811
10812             memcpy (str, h.text, h.length);
10813             memset (&str[h.length], ' ',
10814                     FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE
10815                     - h.length);
10816             item = build_string (FLOAT_TYPE_SIZE / CHAR_TYPE_SIZE,
10817                                  str);
10818           }
10819         TREE_TYPE (item)
10820           = build_type_variant (build_array_type (char_type_node,
10821                                                   build_range_type
10822                                                   (integer_type_node,
10823                                                    integer_one_node,
10824                                                    build_int_2
10825                                                    (h.length, 0))),
10826                                 1, 0);
10827       }
10828       break;
10829
10830     case FFEINFO_basictypeTYPELESS:
10831       {
10832         ffetargetInteger1 ival;
10833         ffetargetTypeless tless;
10834         ffebad error;
10835
10836         tless = ffebld_cu_val_typeless (*cu);
10837         error = ffetarget_convert_integer1_typeless (&ival, tless);
10838         assert (error == FFEBAD);
10839
10840         item = build_int_2 ((int) ival, 0);
10841       }
10842       break;
10843
10844     default:
10845       assert ("not yet on constant type" == NULL);
10846       /* Fall through. */
10847     case FFEINFO_basictypeANY:
10848       return error_mark_node;
10849     }
10850
10851   TREE_CONSTANT (item) = 1;
10852
10853   return item;
10854 }
10855
10856 #endif
10857
10858 /* Transform expression into constant tree.
10859
10860    If the expression can be transformed into a tree that is constant,
10861    that is done, and the tree returned.  Else NULL_TREE is returned.
10862
10863    That way, a caller can attempt to provide compile-time initialization
10864    of a variable and, if that fails, *then* choose to start a new block
10865    and resort to using temporaries, as appropriate.  */
10866
10867 tree
10868 ffecom_const_expr (ffebld expr)
10869 {
10870   if (! expr)
10871     return integer_zero_node;
10872
10873   if (ffebld_op (expr) == FFEBLD_opANY)
10874     return error_mark_node;
10875
10876   if (ffebld_arity (expr) == 0
10877       && (ffebld_op (expr) != FFEBLD_opSYMTER
10878 #if NEWCOMMON
10879           /* ~~Enable once common/equivalence is handled properly?  */
10880           || ffebld_where (expr) == FFEINFO_whereCOMMON
10881 #endif
10882           || ffebld_where (expr) == FFEINFO_whereGLOBAL
10883           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
10884     {
10885       tree t;
10886
10887       t = ffecom_expr (expr);
10888       assert (TREE_CONSTANT (t));
10889       return t;
10890     }
10891
10892   return NULL_TREE;
10893 }
10894
10895 /* Handy way to make a field in a struct/union.  */
10896
10897 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10898 tree
10899 ffecom_decl_field (tree context, tree prevfield,
10900                    const char *name, tree type)
10901 {
10902   tree field;
10903
10904   field = build_decl (FIELD_DECL, get_identifier (name), type);
10905   DECL_CONTEXT (field) = context;
10906   DECL_ALIGN (field) = 0;
10907   DECL_USER_ALIGN (field) = 0;
10908   if (prevfield != NULL_TREE)
10909     TREE_CHAIN (prevfield) = field;
10910
10911   return field;
10912 }
10913
10914 #endif
10915
10916 void
10917 ffecom_close_include (FILE *f)
10918 {
10919 #if FFECOM_GCC_INCLUDE
10920   ffecom_close_include_ (f);
10921 #endif
10922 }
10923
10924 int
10925 ffecom_decode_include_option (char *spec)
10926 {
10927 #if FFECOM_GCC_INCLUDE
10928   return ffecom_decode_include_option_ (spec);
10929 #else
10930   return 1;
10931 #endif
10932 }
10933
10934 /* End a compound statement (block).  */
10935
10936 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10937 tree
10938 ffecom_end_compstmt (void)
10939 {
10940   return bison_rule_compstmt_ ();
10941 }
10942 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
10943
10944 /* ffecom_end_transition -- Perform end transition on all symbols
10945
10946    ffecom_end_transition();
10947
10948    Calls ffecom_sym_end_transition for each global and local symbol.  */
10949
10950 void
10951 ffecom_end_transition ()
10952 {
10953 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10954   ffebld item;
10955 #endif
10956
10957   if (ffe_is_ffedebug ())
10958     fprintf (dmpout, "; end_stmt_transition\n");
10959
10960 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10961   ffecom_list_blockdata_ = NULL;
10962   ffecom_list_common_ = NULL;
10963 #endif
10964
10965   ffesymbol_drive (ffecom_sym_end_transition);
10966   if (ffe_is_ffedebug ())
10967     {
10968       ffestorag_report ();
10969 #if FFECOM_targetCURRENT == FFECOM_targetFFE
10970       ffesymbol_report_all ();
10971 #endif
10972     }
10973
10974 #if FFECOM_targetCURRENT == FFECOM_targetGCC
10975   ffecom_start_progunit_ ();
10976
10977   for (item = ffecom_list_blockdata_;
10978        item != NULL;
10979        item = ffebld_trail (item))
10980     {
10981       ffebld callee;
10982       ffesymbol s;
10983       tree dt;
10984       tree t;
10985       tree var;
10986       static int number = 0;
10987
10988       callee = ffebld_head (item);
10989       s = ffebld_symter (callee);
10990       t = ffesymbol_hook (s).decl_tree;
10991       if (t == NULL_TREE)
10992         {
10993           s = ffecom_sym_transform_ (s);
10994           t = ffesymbol_hook (s).decl_tree;
10995         }
10996
10997       dt = build_pointer_type (TREE_TYPE (t));
10998
10999       var = build_decl (VAR_DECL,
11000                         ffecom_get_invented_identifier ("__g77_forceload_%d",
11001                                                         number++),
11002                         dt);
11003       DECL_EXTERNAL (var) = 0;
11004       TREE_STATIC (var) = 1;
11005       TREE_PUBLIC (var) = 0;
11006       DECL_INITIAL (var) = error_mark_node;
11007       TREE_USED (var) = 1;
11008
11009       var = start_decl (var, FALSE);
11010
11011       t = ffecom_1 (ADDR_EXPR, dt, t);
11012
11013       finish_decl (var, t, FALSE);
11014     }
11015
11016   /* This handles any COMMON areas that weren't referenced but have, for
11017      example, important initial data.  */
11018
11019   for (item = ffecom_list_common_;
11020        item != NULL;
11021        item = ffebld_trail (item))
11022     ffecom_transform_common_ (ffebld_symter (ffebld_head (item)));
11023
11024   ffecom_list_common_ = NULL;
11025 #endif
11026 }
11027
11028 /* ffecom_exec_transition -- Perform exec transition on all symbols
11029
11030    ffecom_exec_transition();
11031
11032    Calls ffecom_sym_exec_transition for each global and local symbol.
11033    Make sure error updating not inhibited.  */
11034
11035 void
11036 ffecom_exec_transition ()
11037 {
11038   bool inhibited;
11039
11040   if (ffe_is_ffedebug ())
11041     fprintf (dmpout, "; exec_stmt_transition\n");
11042
11043   inhibited = ffebad_inhibit ();
11044   ffebad_set_inhibit (FALSE);
11045
11046   ffesymbol_drive (ffecom_sym_exec_transition); /* Don't retract! */
11047   ffeequiv_exec_transition ();  /* Handle all pending EQUIVALENCEs. */
11048   if (ffe_is_ffedebug ())
11049     {
11050       ffestorag_report ();
11051 #if FFECOM_targetCURRENT == FFECOM_targetFFE
11052       ffesymbol_report_all ();
11053 #endif
11054     }
11055
11056   if (inhibited)
11057     ffebad_set_inhibit (TRUE);
11058 }
11059
11060 /* Handle assignment statement.
11061
11062    Convert dest and source using ffecom_expr, then join them
11063    with an ASSIGN op and pass the whole thing to expand_expr_stmt.  */
11064
11065 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11066 void
11067 ffecom_expand_let_stmt (ffebld dest, ffebld source)
11068 {
11069   tree dest_tree;
11070   tree dest_length;
11071   tree source_tree;
11072   tree expr_tree;
11073
11074   if (ffeinfo_basictype (ffebld_info (dest)) != FFEINFO_basictypeCHARACTER)
11075     {
11076       bool dest_used;
11077       tree assign_temp;
11078
11079       /* This attempts to replicate the test below, but must not be
11080          true when the test below is false.  (Always err on the side
11081          of creating unused temporaries, to avoid ICEs.)  */
11082       if (ffebld_op (dest) != FFEBLD_opSYMTER
11083           || ((dest_tree = ffesymbol_hook (ffebld_symter (dest)).decl_tree)
11084               && (TREE_CODE (dest_tree) != VAR_DECL
11085                   || TREE_ADDRESSABLE (dest_tree))))
11086         {
11087           ffecom_prepare_expr_ (source, dest);
11088           dest_used = TRUE;
11089         }
11090       else
11091         {
11092           ffecom_prepare_expr_ (source, NULL);
11093           dest_used = FALSE;
11094         }
11095
11096       ffecom_prepare_expr_w (NULL_TREE, dest);
11097
11098       /* For COMPLEX assignment like C1=C2, if partial overlap is possible,
11099          create a temporary through which the assignment is to take place,
11100          since MODIFY_EXPR doesn't handle partial overlap properly.  */
11101       if (ffebld_basictype (dest) == FFEINFO_basictypeCOMPLEX
11102           && ffecom_possible_partial_overlap_ (dest, source))
11103         {
11104           assign_temp = ffecom_make_tempvar ("complex_let",
11105                                              ffecom_tree_type
11106                                              [ffebld_basictype (dest)]
11107                                              [ffebld_kindtype (dest)],
11108                                              FFETARGET_charactersizeNONE,
11109                                              -1);
11110         }
11111       else
11112         assign_temp = NULL_TREE;
11113
11114       ffecom_prepare_end ();
11115
11116       dest_tree = ffecom_expr_w (NULL_TREE, dest);
11117       if (dest_tree == error_mark_node)
11118         return;
11119
11120       if ((TREE_CODE (dest_tree) != VAR_DECL)
11121           || TREE_ADDRESSABLE (dest_tree))
11122         source_tree = ffecom_expr_ (source, dest_tree, dest, &dest_used,
11123                                     FALSE, FALSE);
11124       else
11125         {
11126           assert (! dest_used);
11127           dest_used = FALSE;
11128           source_tree = ffecom_expr (source);
11129         }
11130       if (source_tree == error_mark_node)
11131         return;
11132
11133       if (dest_used)
11134         expr_tree = source_tree;
11135       else if (assign_temp)
11136         {
11137 #ifdef MOVE_EXPR
11138           /* The back end understands a conceptual move (evaluate source;
11139              store into dest), so use that, in case it can determine
11140              that it is going to use, say, two registers as temporaries
11141              anyway.  So don't use the temp (and someday avoid generating
11142              it, once this code starts triggering regularly).  */
11143           expr_tree = ffecom_2s (MOVE_EXPR, void_type_node,
11144                                  dest_tree,
11145                                  source_tree);
11146 #else
11147           expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11148                                  assign_temp,
11149                                  source_tree);
11150           expand_expr_stmt (expr_tree);
11151           expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11152                                  dest_tree,
11153                                  assign_temp);
11154 #endif
11155         }
11156       else
11157         expr_tree = ffecom_2s (MODIFY_EXPR, void_type_node,
11158                                dest_tree,
11159                                source_tree);
11160
11161       expand_expr_stmt (expr_tree);
11162       return;
11163     }
11164
11165   ffecom_prepare_let_char_ (ffebld_size_known (dest), source);
11166   ffecom_prepare_expr_w (NULL_TREE, dest);
11167
11168   ffecom_prepare_end ();
11169
11170   ffecom_char_args_ (&dest_tree, &dest_length, dest);
11171   ffecom_let_char_ (dest_tree, dest_length, ffebld_size_known (dest),
11172                     source);
11173 }
11174
11175 #endif
11176 /* ffecom_expr -- Transform expr into gcc tree
11177
11178    tree t;
11179    ffebld expr;  // FFE expression.
11180    tree = ffecom_expr(expr);
11181
11182    Recursive descent on expr while making corresponding tree nodes and
11183    attaching type info and such.  */
11184
11185 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11186 tree
11187 ffecom_expr (ffebld expr)
11188 {
11189   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, FALSE, FALSE);
11190 }
11191
11192 #endif
11193 /* Like ffecom_expr, but return tree usable for assigned GOTO or FORMAT.  */
11194
11195 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11196 tree
11197 ffecom_expr_assign (ffebld expr)
11198 {
11199   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
11200 }
11201
11202 #endif
11203 /* Like ffecom_expr_rw, but return tree usable for ASSIGN.  */
11204
11205 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11206 tree
11207 ffecom_expr_assign_w (ffebld expr)
11208 {
11209   return ffecom_expr_ (expr, NULL_TREE, NULL, NULL, TRUE, FALSE);
11210 }
11211
11212 #endif
11213 /* Transform expr for use as into read/write tree and stabilize the
11214    reference.  Not for use on CHARACTER expressions.
11215
11216    Recursive descent on expr while making corresponding tree nodes and
11217    attaching type info and such.  */
11218
11219 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11220 tree
11221 ffecom_expr_rw (tree type, ffebld expr)
11222 {
11223   assert (expr != NULL);
11224   /* Different target types not yet supported.  */
11225   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
11226
11227   return stabilize_reference (ffecom_expr (expr));
11228 }
11229
11230 #endif
11231 /* Transform expr for use as into write tree and stabilize the
11232    reference.  Not for use on CHARACTER expressions.
11233
11234    Recursive descent on expr while making corresponding tree nodes and
11235    attaching type info and such.  */
11236
11237 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11238 tree
11239 ffecom_expr_w (tree type, ffebld expr)
11240 {
11241   assert (expr != NULL);
11242   /* Different target types not yet supported.  */
11243   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
11244
11245   return stabilize_reference (ffecom_expr (expr));
11246 }
11247
11248 #endif
11249 /* Do global stuff.  */
11250
11251 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11252 void
11253 ffecom_finish_compile ()
11254 {
11255   assert (ffecom_outer_function_decl_ == NULL_TREE);
11256   assert (current_function_decl == NULL_TREE);
11257
11258   ffeglobal_drive (ffecom_finish_global_);
11259 }
11260
11261 #endif
11262 /* Public entry point for front end to access finish_decl.  */
11263
11264 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11265 void
11266 ffecom_finish_decl (tree decl, tree init, bool is_top_level)
11267 {
11268   assert (!is_top_level);
11269   finish_decl (decl, init, FALSE);
11270 }
11271
11272 #endif
11273 /* Finish a program unit.  */
11274
11275 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11276 void
11277 ffecom_finish_progunit ()
11278 {
11279   ffecom_end_compstmt ();
11280
11281   ffecom_previous_function_decl_ = current_function_decl;
11282   ffecom_which_entrypoint_decl_ = NULL_TREE;
11283
11284   finish_function (0);
11285 }
11286
11287 #endif
11288
11289 /* Wrapper for get_identifier.  pattern is sprintf-like.  */
11290
11291 #if FFECOM_targetCURRENT == FFECOM_targetGCC
11292 tree
11293 ffecom_get_invented_identifier (const char *pattern, ...)
11294 {
11295   tree decl;
11296   char *nam;
11297   va_list ap;
11298
11299   va_start (ap, pattern);
11300   if (vasprintf (&nam, pattern, ap) == 0)
11301     abort ();
11302   va_end (ap);
11303   decl = get_identifier (nam);
11304   free (nam);
11305   IDENTIFIER_INVENTED (decl) = 1;
11306   return decl;
11307 }
11308
11309 ffeinfoBasictype
11310 ffecom_gfrt_basictype (ffecomGfrt gfrt)
11311 {
11312   assert (gfrt < FFECOM_gfrt);
11313
11314   switch (ffecom_gfrt_type_[gfrt])
11315     {
11316     case FFECOM_rttypeVOID_:
11317     case FFECOM_rttypeVOIDSTAR_:
11318       return FFEINFO_basictypeNONE;
11319
11320     case FFECOM_rttypeFTNINT_:
11321       return FFEINFO_basictypeINTEGER;
11322
11323     case FFECOM_rttypeINTEGER_:
11324       return FFEINFO_basictypeINTEGER;
11325
11326     case FFECOM_rttypeLONGINT_:
11327       return FFEINFO_basictypeINTEGER;
11328
11329     case FFECOM_rttypeLOGICAL_:
11330       return FFEINFO_basictypeLOGICAL;
11331
11332     case FFECOM_rttypeREAL_F2C_:
11333     case FFECOM_rttypeREAL_GNU_:
11334       return FFEINFO_basictypeREAL;
11335
11336     case FFECOM_rttypeCOMPLEX_F2C_:
11337     case FFECOM_rttypeCOMPLEX_GNU_:
11338       return FFEINFO_basictypeCOMPLEX;
11339
11340     case FFECOM_rttypeDOUBLE_:
11341     case FFECOM_rttypeDOUBLEREAL_:
11342       return FFEINFO_basictypeREAL;
11343
11344     case FFECOM_rttypeDBLCMPLX_F2C_:
11345     case FFECOM_rttypeDBLCMPLX_GNU_:
11346       return FFEINFO_basictypeCOMPLEX;
11347
11348     case FFECOM_rttypeCHARACTER_:
11349       return FFEINFO_basictypeCHARACTER;
11350
11351     default:
11352       return FFEINFO_basictypeANY;
11353     }
11354 }
11355
11356 ffeinfoKindtype
11357 ffecom_gfrt_kindtype (ffecomGfrt gfrt)
11358 {
11359   assert (gfrt < FFECOM_gfrt);
11360
11361   switch (ffecom_gfrt_type_[gfrt])
11362     {
11363     case FFECOM_rttypeVOID_:
11364     case FFECOM_rttypeVOIDSTAR_:
11365       return FFEINFO_kindtypeNONE;
11366
11367     case FFECOM_rttypeFTNINT_:
11368       return FFEINFO_kindtypeINTEGER1;
11369
11370     case FFECOM_rttypeINTEGER_:
11371       return FFEINFO_kindtypeINTEGER1;
11372
11373     case FFECOM_rttypeLONGINT_:
11374       return FFEINFO_kindtypeINTEGER4;
11375
11376     case FFECOM_rttypeLOGICAL_:
11377       return FFEINFO_kindtypeLOGICAL1;
11378
11379     case FFECOM_rttypeREAL_F2C_:
11380     case FFECOM_rttypeREAL_GNU_:
11381       return FFEINFO_kindtypeREAL1;
11382
11383     case FFECOM_rttypeCOMPLEX_F2C_:
11384     case FFECOM_rttypeCOMPLEX_GNU_:
11385       return FFEINFO_kindtypeREAL1;
11386
11387     case FFECOM_rttypeDOUBLE_:
11388     case FFECOM_rttypeDOUBLEREAL_:
11389       return FFEINFO_kindtypeREAL2;
11390
11391     case FFECOM_rttypeDBLCMPLX_F2C_:
11392     case FFECOM_rttypeDBLCMPLX_GNU_:
11393       return FFEINFO_kindtypeREAL2;
11394
11395     case FFECOM_rttypeCHARACTER_:
11396       return FFEINFO_kindtypeCHARACTER1;
11397
11398     default:
11399       return FFEINFO_kindtypeANY;
11400     }
11401 }
11402
11403 void
11404 ffecom_init_0 ()
11405 {
11406   tree endlink;
11407   int i;
11408   int j;
11409   tree t;
11410   tree field;
11411   ffetype type;
11412   ffetype base_type;
11413   tree double_ftype_double;
11414   tree float_ftype_float;
11415   tree ldouble_ftype_ldouble;
11416   tree ffecom_tree_ptr_to_fun_type_void;
11417
11418   /* This block of code comes from the now-obsolete cktyps.c.  It checks
11419      whether the compiler environment is buggy in known ways, some of which
11420      would, if not explicitly checked here, result in subtle bugs in g77.  */
11421
11422   if (ffe_is_do_internal_checks ())
11423     {
11424       static char names[][12]
11425         =
11426       {"bar", "bletch", "foo", "foobar"};
11427       char *name;
11428       unsigned long ul;
11429       double fl;
11430
11431       name = bsearch ("foo", &names[0], ARRAY_SIZE (names), sizeof (names[0]),
11432                       (int (*)(const void *, const void *)) strcmp);
11433       if (name != (char *) &names[2])
11434         {
11435           assert ("bsearch doesn't work, #define FFEPROJ_BSEARCH 0 in proj.h"
11436                   == NULL);
11437           abort ();
11438         }
11439
11440       ul = strtoul ("123456789", NULL, 10);
11441       if (ul != 123456789L)
11442         {
11443           assert ("strtoul doesn't have enough range, #define FFEPROJ_STRTOUL 0\
11444  in proj.h" == NULL);
11445           abort ();
11446         }
11447
11448       fl = atof ("56.789");
11449       if ((fl < 56.788) || (fl > 56.79))
11450         {
11451           assert ("atof not type double, fix your #include <stdio.h>"
11452                   == NULL);
11453           abort ();
11454         }
11455     }
11456
11457 #if FFECOM_GCC_INCLUDE
11458   ffecom_initialize_char_syntax_ ();
11459 #endif
11460
11461   ffecom_outer_function_decl_ = NULL_TREE;
11462   current_function_decl = NULL_TREE;
11463   named_labels = NULL_TREE;
11464   current_binding_level = NULL_BINDING_LEVEL;
11465   free_binding_level = NULL_BINDING_LEVEL;
11466   /* Make the binding_level structure for global names.  */
11467   pushlevel (0);
11468   global_binding_level = current_binding_level;
11469   current_binding_level->prep_state = 2;
11470
11471   build_common_tree_nodes (1);
11472
11473   /* Define `int' and `char' first so that dbx will output them first.  */
11474   pushdecl (build_decl (TYPE_DECL, get_identifier ("int"),
11475                         integer_type_node));
11476   pushdecl (build_decl (TYPE_DECL, get_identifier ("char"),
11477                         char_type_node));
11478   pushdecl (build_decl (TYPE_DECL, get_identifier ("long int"),
11479                         long_integer_type_node));
11480   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"),
11481                         unsigned_type_node));
11482   pushdecl (build_decl (TYPE_DECL, get_identifier ("long unsigned int"),
11483                         long_unsigned_type_node));
11484   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long int"),
11485                         long_long_integer_type_node));
11486   pushdecl (build_decl (TYPE_DECL, get_identifier ("long long unsigned int"),
11487                         long_long_unsigned_type_node));
11488   pushdecl (build_decl (TYPE_DECL, get_identifier ("short int"),
11489                         short_integer_type_node));
11490   pushdecl (build_decl (TYPE_DECL, get_identifier ("short unsigned int"),
11491                         short_unsigned_type_node));
11492
11493   /* Set the sizetype before we make other types.  This *should* be the
11494      first type we create.  */
11495
11496   set_sizetype
11497     (TREE_TYPE (IDENTIFIER_GLOBAL_VALUE (get_identifier (SIZE_TYPE))));
11498   ffecom_typesize_pointer_
11499     = TREE_INT_CST_LOW (TYPE_SIZE (sizetype)) / BITS_PER_UNIT;
11500
11501   build_common_tree_nodes_2 (0);
11502
11503   /* Define both `signed char' and `unsigned char'.  */
11504   pushdecl (build_decl (TYPE_DECL, get_identifier ("signed char"),
11505                         signed_char_type_node));
11506
11507   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"),
11508                         unsigned_char_type_node));
11509
11510   pushdecl (build_decl (TYPE_DECL, get_identifier ("float"),
11511                         float_type_node));
11512   pushdecl (build_decl (TYPE_DECL, get_identifier ("double"),
11513                         double_type_node));
11514   pushdecl (build_decl (TYPE_DECL, get_identifier ("long double"),
11515                         long_double_type_node));
11516
11517   /* For now, override what build_common_tree_nodes has done.  */
11518   complex_integer_type_node = ffecom_make_complex_type_ (integer_type_node);
11519   complex_float_type_node = ffecom_make_complex_type_ (float_type_node);
11520   complex_double_type_node = ffecom_make_complex_type_ (double_type_node);
11521   complex_long_double_type_node
11522     = ffecom_make_complex_type_ (long_double_type_node);
11523
11524   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex int"),
11525                         complex_integer_type_node));
11526   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex float"),
11527                         complex_float_type_node));
11528   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex double"),
11529                         complex_double_type_node));
11530   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex long double"),
11531                         complex_long_double_type_node));
11532
11533   pushdecl (build_decl (TYPE_DECL, get_identifier ("void"),
11534                         void_type_node));
11535   /* We are not going to have real types in C with less than byte alignment,
11536      so we might as well not have any types that claim to have it.  */
11537   TYPE_ALIGN (void_type_node) = BITS_PER_UNIT;
11538   TYPE_USER_ALIGN (void_type_node) = 0;
11539
11540   string_type_node = build_pointer_type (char_type_node);
11541
11542   ffecom_tree_fun_type_void
11543     = build_function_type (void_type_node, NULL_TREE);
11544
11545   ffecom_tree_ptr_to_fun_type_void
11546     = build_pointer_type (ffecom_tree_fun_type_void);
11547
11548   endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
11549
11550   float_ftype_float
11551     = build_function_type (float_type_node,
11552                            tree_cons (NULL_TREE, float_type_node, endlink));
11553
11554   double_ftype_double
11555     = build_function_type (double_type_node,
11556                            tree_cons (NULL_TREE, double_type_node, endlink));
11557
11558   ldouble_ftype_ldouble
11559     = build_function_type (long_double_type_node,
11560                            tree_cons (NULL_TREE, long_double_type_node,
11561                                       endlink));
11562
11563   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11564     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11565       {
11566         ffecom_tree_type[i][j] = NULL_TREE;
11567         ffecom_tree_fun_type[i][j] = NULL_TREE;
11568         ffecom_tree_ptr_to_fun_type[i][j] = NULL_TREE;
11569         ffecom_f2c_typecode_[i][j] = -1;
11570       }
11571
11572   /* Set up standard g77 types.  Note that INTEGER and LOGICAL are set
11573      to size FLOAT_TYPE_SIZE because they have to be the same size as
11574      REAL, which also is FLOAT_TYPE_SIZE, according to the standard.
11575      Compiler options and other such stuff that change the ways these
11576      types are set should not affect this particular setup.  */
11577
11578   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1]
11579     = t = make_signed_type (FLOAT_TYPE_SIZE);
11580   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer"),
11581                         t));
11582   type = ffetype_new ();
11583   base_type = type;
11584   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER1,
11585                     type);
11586   ffetype_set_ams (type,
11587                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11588                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11589   ffetype_set_star (base_type,
11590                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11591                     type);
11592   ffetype_set_kind (base_type, 1, type);
11593   ffecom_typesize_integer1_ = ffetype_size (type);
11594   assert (ffetype_size (type) == sizeof (ffetargetInteger1));
11595
11596   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER1]
11597     = t = make_unsigned_type (FLOAT_TYPE_SIZE); /* HOLLERITH means unsigned. */
11598   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned"),
11599                         t));
11600
11601   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER2]
11602     = t = make_signed_type (CHAR_TYPE_SIZE);
11603   pushdecl (build_decl (TYPE_DECL, get_identifier ("byte"),
11604                         t));
11605   type = ffetype_new ();
11606   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER2,
11607                     type);
11608   ffetype_set_ams (type,
11609                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11610                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11611   ffetype_set_star (base_type,
11612                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11613                     type);
11614   ffetype_set_kind (base_type, 3, type);
11615   assert (ffetype_size (type) == sizeof (ffetargetInteger2));
11616
11617   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER2]
11618     = t = make_unsigned_type (CHAR_TYPE_SIZE);
11619   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned byte"),
11620                         t));
11621
11622   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER3]
11623     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11624   pushdecl (build_decl (TYPE_DECL, get_identifier ("word"),
11625                         t));
11626   type = ffetype_new ();
11627   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER3,
11628                     type);
11629   ffetype_set_ams (type,
11630                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11631                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11632   ffetype_set_star (base_type,
11633                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11634                     type);
11635   ffetype_set_kind (base_type, 6, type);
11636   assert (ffetype_size (type) == sizeof (ffetargetInteger3));
11637
11638   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER3]
11639     = t = make_unsigned_type (CHAR_TYPE_SIZE * 2);
11640   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned word"),
11641                         t));
11642
11643   ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER4]
11644     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11645   pushdecl (build_decl (TYPE_DECL, get_identifier ("integer4"),
11646                         t));
11647   type = ffetype_new ();
11648   ffeinfo_set_type (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGER4,
11649                     type);
11650   ffetype_set_ams (type,
11651                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11652                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11653   ffetype_set_star (base_type,
11654                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11655                     type);
11656   ffetype_set_kind (base_type, 2, type);
11657   assert (ffetype_size (type) == sizeof (ffetargetInteger4));
11658
11659   ffecom_tree_type[FFEINFO_basictypeHOLLERITH][FFEINFO_kindtypeINTEGER4]
11660     = t = make_unsigned_type (FLOAT_TYPE_SIZE * 2);
11661   pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned4"),
11662                         t));
11663
11664 #if 0
11665   if (ffe_is_do_internal_checks ()
11666       && LONG_TYPE_SIZE != FLOAT_TYPE_SIZE
11667       && LONG_TYPE_SIZE != CHAR_TYPE_SIZE
11668       && LONG_TYPE_SIZE != SHORT_TYPE_SIZE
11669       && LONG_TYPE_SIZE != LONG_LONG_TYPE_SIZE)
11670     {
11671       fprintf (stderr, "Sorry, no g77 support for LONG_TYPE_SIZE (%d bits) yet.\n",
11672                LONG_TYPE_SIZE);
11673     }
11674 #endif
11675
11676   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL1]
11677     = t = make_signed_type (FLOAT_TYPE_SIZE);
11678   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical"),
11679                         t));
11680   type = ffetype_new ();
11681   base_type = type;
11682   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL1,
11683                     type);
11684   ffetype_set_ams (type,
11685                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11686                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11687   ffetype_set_star (base_type,
11688                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11689                     type);
11690   ffetype_set_kind (base_type, 1, type);
11691   assert (ffetype_size (type) == sizeof (ffetargetLogical1));
11692
11693   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL2]
11694     = t = make_signed_type (CHAR_TYPE_SIZE);
11695   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical2"),
11696                         t));
11697   type = ffetype_new ();
11698   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL2,
11699                     type);
11700   ffetype_set_ams (type,
11701                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11702                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11703   ffetype_set_star (base_type,
11704                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11705                     type);
11706   ffetype_set_kind (base_type, 3, type);
11707   assert (ffetype_size (type) == sizeof (ffetargetLogical2));
11708
11709   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL3]
11710     = t = make_signed_type (CHAR_TYPE_SIZE * 2);
11711   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical3"),
11712                         t));
11713   type = ffetype_new ();
11714   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL3,
11715                     type);
11716   ffetype_set_ams (type,
11717                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11718                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11719   ffetype_set_star (base_type,
11720                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11721                     type);
11722   ffetype_set_kind (base_type, 6, type);
11723   assert (ffetype_size (type) == sizeof (ffetargetLogical3));
11724
11725   ffecom_tree_type[FFEINFO_basictypeLOGICAL][FFEINFO_kindtypeLOGICAL4]
11726     = t = make_signed_type (FLOAT_TYPE_SIZE * 2);
11727   pushdecl (build_decl (TYPE_DECL, get_identifier ("logical4"),
11728                         t));
11729   type = ffetype_new ();
11730   ffeinfo_set_type (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICAL4,
11731                     type);
11732   ffetype_set_ams (type,
11733                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11734                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11735   ffetype_set_star (base_type,
11736                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11737                     type);
11738   ffetype_set_kind (base_type, 2, type);
11739   assert (ffetype_size (type) == sizeof (ffetargetLogical4));
11740
11741   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11742     = t = make_node (REAL_TYPE);
11743   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE;
11744   pushdecl (build_decl (TYPE_DECL, get_identifier ("real"),
11745                         t));
11746   layout_type (t);
11747   type = ffetype_new ();
11748   base_type = type;
11749   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREAL1,
11750                     type);
11751   ffetype_set_ams (type,
11752                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11753                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11754   ffetype_set_star (base_type,
11755                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11756                     type);
11757   ffetype_set_kind (base_type, 1, type);
11758   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]
11759     = FFETARGET_f2cTYREAL;
11760   assert (ffetype_size (type) == sizeof (ffetargetReal1));
11761
11762   ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREALDOUBLE]
11763     = t = make_node (REAL_TYPE);
11764   TYPE_PRECISION (t) = FLOAT_TYPE_SIZE * 2;     /* Always twice REAL. */
11765   pushdecl (build_decl (TYPE_DECL, get_identifier ("double precision"),
11766                         t));
11767   layout_type (t);
11768   type = ffetype_new ();
11769   ffeinfo_set_type (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
11770                     type);
11771   ffetype_set_ams (type,
11772                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11773                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11774   ffetype_set_star (base_type,
11775                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11776                     type);
11777   ffetype_set_kind (base_type, 2, type);
11778   ffecom_f2c_typecode_[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]
11779     = FFETARGET_f2cTYDREAL;
11780   assert (ffetype_size (type) == sizeof (ffetargetReal2));
11781
11782   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11783     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL1]);
11784   pushdecl (build_decl (TYPE_DECL, get_identifier ("complex"),
11785                         t));
11786   type = ffetype_new ();
11787   base_type = type;
11788   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREAL1,
11789                     type);
11790   ffetype_set_ams (type,
11791                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11792                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11793   ffetype_set_star (base_type,
11794                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11795                     type);
11796   ffetype_set_kind (base_type, 1, type);
11797   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL1]
11798     = FFETARGET_f2cTYCOMPLEX;
11799   assert (ffetype_size (type) == sizeof (ffetargetComplex1));
11800
11801   ffecom_tree_type[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREALDOUBLE]
11802     = t = ffecom_make_complex_type_ (ffecom_tree_type[FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2]);
11803   pushdecl (build_decl (TYPE_DECL, get_identifier ("double complex"),
11804                         t));
11805   type = ffetype_new ();
11806   ffeinfo_set_type (FFEINFO_basictypeCOMPLEX, FFEINFO_kindtypeREALDOUBLE,
11807                     type);
11808   ffetype_set_ams (type,
11809                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11810                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11811   ffetype_set_star (base_type,
11812                     TREE_INT_CST_LOW (TYPE_SIZE (t)) / CHAR_TYPE_SIZE,
11813                     type);
11814   ffetype_set_kind (base_type, 2,
11815                     type);
11816   ffecom_f2c_typecode_[FFEINFO_basictypeCOMPLEX][FFEINFO_kindtypeREAL2]
11817     = FFETARGET_f2cTYDCOMPLEX;
11818   assert (ffetype_size (type) == sizeof (ffetargetComplex2));
11819
11820   /* Make function and ptr-to-function types for non-CHARACTER types. */
11821
11822   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11823     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11824       {
11825         if ((t = ffecom_tree_type[i][j]) != NULL_TREE)
11826           {
11827             if (i == FFEINFO_basictypeINTEGER)
11828               {
11829                 /* Figure out the smallest INTEGER type that can hold
11830                    a pointer on this machine. */
11831                 if (GET_MODE_SIZE (TYPE_MODE (t))
11832                     >= GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (null_pointer_node))))
11833                   {
11834                     if ((ffecom_pointer_kind_ == FFEINFO_kindtypeNONE)
11835                         || (GET_MODE_SIZE (TYPE_MODE (ffecom_tree_type[i][ffecom_pointer_kind_]))
11836                             > GET_MODE_SIZE (TYPE_MODE (t))))
11837                       ffecom_pointer_kind_ = j;
11838                   }
11839               }
11840             else if (i == FFEINFO_basictypeCOMPLEX)
11841               t = void_type_node;
11842             /* For f2c compatibility, REAL functions are really
11843                implemented as DOUBLE PRECISION.  */
11844             else if ((i == FFEINFO_basictypeREAL)
11845                      && (j == FFEINFO_kindtypeREAL1))
11846               t = ffecom_tree_type
11847                 [FFEINFO_basictypeREAL][FFEINFO_kindtypeREAL2];
11848
11849             t = ffecom_tree_fun_type[i][j] = build_function_type (t,
11850                                                                   NULL_TREE);
11851             ffecom_tree_ptr_to_fun_type[i][j] = build_pointer_type (t);
11852           }
11853       }
11854
11855   /* Set up pointer types.  */
11856
11857   if (ffecom_pointer_kind_ == FFEINFO_basictypeNONE)
11858     fatal_error ("no INTEGER type can hold a pointer on this configuration");
11859   else if (0 && ffe_is_do_internal_checks ())
11860     fprintf (stderr, "Pointer type kt=%d\n", ffecom_pointer_kind_);
11861   ffetype_set_kind (ffeinfo_type (FFEINFO_basictypeINTEGER,
11862                                   FFEINFO_kindtypeINTEGERDEFAULT),
11863                     7,
11864                     ffeinfo_type (FFEINFO_basictypeINTEGER,
11865                                   ffecom_pointer_kind_));
11866
11867   if (ffe_is_ugly_assign ())
11868     ffecom_label_kind_ = ffecom_pointer_kind_;  /* Require ASSIGN etc to this. */
11869   else
11870     ffecom_label_kind_ = FFEINFO_kindtypeINTEGERDEFAULT;
11871   if (0 && ffe_is_do_internal_checks ())
11872     fprintf (stderr, "Label type kt=%d\n", ffecom_label_kind_);
11873
11874   ffecom_integer_type_node
11875     = ffecom_tree_type[FFEINFO_basictypeINTEGER][FFEINFO_kindtypeINTEGER1];
11876   ffecom_integer_zero_node = convert (ffecom_integer_type_node,
11877                                       integer_zero_node);
11878   ffecom_integer_one_node = convert (ffecom_integer_type_node,
11879                                      integer_one_node);
11880
11881   /* Yes, the "FLOAT_TYPE_SIZE" references below are intentional.
11882      Turns out that by TYLONG, runtime/libI77/lio.h really means
11883      "whatever size an ftnint is".  For consistency and sanity,
11884      com.h and runtime/f2c.h.in agree that flag, ftnint, and ftlen
11885      all are INTEGER, which we also make out of whatever back-end
11886      integer type is FLOAT_TYPE_SIZE bits wide.  This change, from
11887      LONG_TYPE_SIZE, for TYLONG and TYLOGICAL, was necessary to
11888      accommodate machines like the Alpha.  Note that this suggests
11889      f2c and libf2c are missing a distinction perhaps needed on
11890      some machines between "int" and "long int".  -- burley 0.5.5 950215 */
11891
11892   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, FLOAT_TYPE_SIZE,
11893                             FFETARGET_f2cTYLONG);
11894   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, SHORT_TYPE_SIZE,
11895                             FFETARGET_f2cTYSHORT);
11896   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, CHAR_TYPE_SIZE,
11897                             FFETARGET_f2cTYINT1);
11898   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeINTEGER, LONG_LONG_TYPE_SIZE,
11899                             FFETARGET_f2cTYQUAD);
11900   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, FLOAT_TYPE_SIZE,
11901                             FFETARGET_f2cTYLOGICAL);
11902   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, SHORT_TYPE_SIZE,
11903                             FFETARGET_f2cTYLOGICAL2);
11904   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, CHAR_TYPE_SIZE,
11905                             FFETARGET_f2cTYLOGICAL1);
11906   /* ~~~Not really such a type in libf2c, e.g. I/O support?  */
11907   ffecom_f2c_set_lio_code_ (FFEINFO_basictypeLOGICAL, LONG_LONG_TYPE_SIZE,
11908                             FFETARGET_f2cTYQUAD);
11909
11910   /* CHARACTER stuff is all special-cased, so it is not handled in the above
11911      loop.  CHARACTER items are built as arrays of unsigned char.  */
11912
11913   ffecom_tree_type[FFEINFO_basictypeCHARACTER]
11914     [FFEINFO_kindtypeCHARACTER1] = t = char_type_node;
11915   type = ffetype_new ();
11916   base_type = type;
11917   ffeinfo_set_type (FFEINFO_basictypeCHARACTER,
11918                     FFEINFO_kindtypeCHARACTER1,
11919                     type);
11920   ffetype_set_ams (type,
11921                    TYPE_ALIGN (t) / BITS_PER_UNIT, 0,
11922                    TREE_INT_CST_LOW (TYPE_SIZE (t)) / BITS_PER_UNIT);
11923   ffetype_set_kind (base_type, 1, type);
11924   assert (ffetype_size (type)
11925           == sizeof (((ffetargetCharacter1) { 0, NULL }).text[0]));
11926
11927   ffecom_tree_fun_type[FFEINFO_basictypeCHARACTER]
11928     [FFEINFO_kindtypeCHARACTER1] = ffecom_tree_fun_type_void;
11929   ffecom_tree_ptr_to_fun_type[FFEINFO_basictypeCHARACTER]
11930     [FFEINFO_kindtypeCHARACTER1]
11931     = ffecom_tree_ptr_to_fun_type_void;
11932   ffecom_f2c_typecode_[FFEINFO_basictypeCHARACTER][FFEINFO_kindtypeCHARACTER1]
11933     = FFETARGET_f2cTYCHAR;
11934
11935   ffecom_f2c_typecode_[FFEINFO_basictypeANY][FFEINFO_kindtypeANY]
11936     = 0;
11937
11938   /* Make multi-return-value type and fields. */
11939
11940   ffecom_multi_type_node_ = make_node (UNION_TYPE);
11941
11942   field = NULL_TREE;
11943
11944   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
11945     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
11946       {
11947         char name[30];
11948
11949         if (ffecom_tree_type[i][j] == NULL_TREE)
11950           continue;             /* Not supported. */
11951         sprintf (&name[0], "bt_%s_kt_%s",
11952                  ffeinfo_basictype_string ((ffeinfoBasictype) i),
11953                  ffeinfo_kindtype_string ((ffeinfoKindtype) j));
11954         ffecom_multi_fields_[i][j] = build_decl (FIELD_DECL,
11955                                                  get_identifier (name),
11956                                                  ffecom_tree_type[i][j]);
11957         DECL_CONTEXT (ffecom_multi_fields_[i][j])
11958           = ffecom_multi_type_node_;
11959         DECL_ALIGN (ffecom_multi_fields_[i][j]) = 0;
11960         DECL_USER_ALIGN (ffecom_multi_fields_[i][j]) = 0;
11961         TREE_CHAIN (ffecom_multi_fields_[i][j]) = field;
11962         field = ffecom_multi_fields_[i][j];
11963       }
11964
11965   TYPE_FIELDS (ffecom_multi_type_node_) = field;
11966   layout_type (ffecom_multi_type_node_);
11967
11968   /* Subroutines usually return integer because they might have alternate
11969      returns. */
11970
11971   ffecom_tree_subr_type
11972     = build_function_type (integer_type_node, NULL_TREE);
11973   ffecom_tree_ptr_to_subr_type
11974     = build_pointer_type (ffecom_tree_subr_type);
11975   ffecom_tree_blockdata_type
11976     = build_function_type (void_type_node, NULL_TREE);
11977
11978   builtin_function ("__builtin_sqrtf", float_ftype_float,
11979                     BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrtf");
11980   builtin_function ("__builtin_fsqrt", double_ftype_double,
11981                     BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrt");
11982   builtin_function ("__builtin_sqrtl", ldouble_ftype_ldouble,
11983                     BUILT_IN_FSQRT, BUILT_IN_NORMAL, "sqrtl");
11984   builtin_function ("__builtin_sinf", float_ftype_float,
11985                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sinf");
11986   builtin_function ("__builtin_sin", double_ftype_double,
11987                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sin");
11988   builtin_function ("__builtin_sinl", ldouble_ftype_ldouble,
11989                     BUILT_IN_SIN, BUILT_IN_NORMAL, "sinl");
11990   builtin_function ("__builtin_cosf", float_ftype_float,
11991                     BUILT_IN_COS, BUILT_IN_NORMAL, "cosf");
11992   builtin_function ("__builtin_cos", double_ftype_double,
11993                     BUILT_IN_COS, BUILT_IN_NORMAL, "cos");
11994   builtin_function ("__builtin_cosl", ldouble_ftype_ldouble,
11995                     BUILT_IN_COS, BUILT_IN_NORMAL, "cosl");
11996
11997 #if BUILT_FOR_270
11998   pedantic_lvalues = FALSE;
11999 #endif
12000
12001   ffecom_f2c_make_type_ (&ffecom_f2c_integer_type_node,
12002                          FFECOM_f2cINTEGER,
12003                          "integer");
12004   ffecom_f2c_make_type_ (&ffecom_f2c_address_type_node,
12005                          FFECOM_f2cADDRESS,
12006                          "address");
12007   ffecom_f2c_make_type_ (&ffecom_f2c_real_type_node,
12008                          FFECOM_f2cREAL,
12009                          "real");
12010   ffecom_f2c_make_type_ (&ffecom_f2c_doublereal_type_node,
12011                          FFECOM_f2cDOUBLEREAL,
12012                          "doublereal");
12013   ffecom_f2c_make_type_ (&ffecom_f2c_complex_type_node,
12014                          FFECOM_f2cCOMPLEX,
12015                          "complex");
12016   ffecom_f2c_make_type_ (&ffecom_f2c_doublecomplex_type_node,
12017                          FFECOM_f2cDOUBLECOMPLEX,
12018                          "doublecomplex");
12019   ffecom_f2c_make_type_ (&ffecom_f2c_longint_type_node,
12020                          FFECOM_f2cLONGINT,
12021                          "longint");
12022   ffecom_f2c_make_type_ (&ffecom_f2c_logical_type_node,
12023                          FFECOM_f2cLOGICAL,
12024                          "logical");
12025   ffecom_f2c_make_type_ (&ffecom_f2c_flag_type_node,
12026                          FFECOM_f2cFLAG,
12027                          "flag");
12028   ffecom_f2c_make_type_ (&ffecom_f2c_ftnlen_type_node,
12029                          FFECOM_f2cFTNLEN,
12030                          "ftnlen");
12031   ffecom_f2c_make_type_ (&ffecom_f2c_ftnint_type_node,
12032                          FFECOM_f2cFTNINT,
12033                          "ftnint");
12034
12035   ffecom_f2c_ftnlen_zero_node
12036     = convert (ffecom_f2c_ftnlen_type_node, integer_zero_node);
12037
12038   ffecom_f2c_ftnlen_one_node
12039     = convert (ffecom_f2c_ftnlen_type_node, integer_one_node);
12040
12041   ffecom_f2c_ftnlen_two_node = build_int_2 (2, 0);
12042   TREE_TYPE (ffecom_f2c_ftnlen_two_node) = ffecom_integer_type_node;
12043
12044   ffecom_f2c_ptr_to_ftnlen_type_node
12045     = build_pointer_type (ffecom_f2c_ftnlen_type_node);
12046
12047   ffecom_f2c_ptr_to_ftnint_type_node
12048     = build_pointer_type (ffecom_f2c_ftnint_type_node);
12049
12050   ffecom_f2c_ptr_to_integer_type_node
12051     = build_pointer_type (ffecom_f2c_integer_type_node);
12052
12053   ffecom_f2c_ptr_to_real_type_node
12054     = build_pointer_type (ffecom_f2c_real_type_node);
12055
12056   ffecom_float_zero_ = build_real (float_type_node, dconst0);
12057   ffecom_double_zero_ = build_real (double_type_node, dconst0);
12058   {
12059     REAL_VALUE_TYPE point_5;
12060
12061 #ifdef REAL_ARITHMETIC
12062     REAL_ARITHMETIC (point_5, RDIV_EXPR, dconst1, dconst2);
12063 #else
12064     point_5 = .5;
12065 #endif
12066     ffecom_float_half_ = build_real (float_type_node, point_5);
12067     ffecom_double_half_ = build_real (double_type_node, point_5);
12068   }
12069
12070   /* Do "extern int xargc;".  */
12071
12072   ffecom_tree_xargc_ = build_decl (VAR_DECL,
12073                                    get_identifier ("f__xargc"),
12074                                    integer_type_node);
12075   DECL_EXTERNAL (ffecom_tree_xargc_) = 1;
12076   TREE_STATIC (ffecom_tree_xargc_) = 1;
12077   TREE_PUBLIC (ffecom_tree_xargc_) = 1;
12078   ffecom_tree_xargc_ = start_decl (ffecom_tree_xargc_, FALSE);
12079   finish_decl (ffecom_tree_xargc_, NULL_TREE, FALSE);
12080
12081 #if 0   /* This is being fixed, and seems to be working now. */
12082   if ((FLOAT_TYPE_SIZE != 32)
12083       || (TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))) != 32))
12084     {
12085       warning ("configuration: REAL, INTEGER, and LOGICAL are %d bits wide,",
12086                (int) FLOAT_TYPE_SIZE);
12087       warning ("and pointers are %d bits wide, but g77 doesn't yet work",
12088           (int) TREE_INT_CST_LOW (TYPE_SIZE (TREE_TYPE (null_pointer_node))));
12089       warning ("properly unless they all are 32 bits wide.");
12090       warning ("Please keep this in mind before you report bugs.  g77 should");
12091       warning ("support non-32-bit machines better as of version 0.6.");
12092     }
12093 #endif
12094
12095 #if 0   /* Code in ste.c that would crash has been commented out. */
12096   if (TYPE_PRECISION (ffecom_f2c_ftnlen_type_node)
12097       < TYPE_PRECISION (string_type_node))
12098     /* I/O will probably crash.  */
12099     warning ("configuration: char * holds %d bits, but ftnlen only %d",
12100              TYPE_PRECISION (string_type_node),
12101              TYPE_PRECISION (ffecom_f2c_ftnlen_type_node));
12102 #endif
12103
12104 #if 0   /* ASSIGN-related stuff has been changed to accommodate this. */
12105   if (TYPE_PRECISION (ffecom_integer_type_node)
12106       < TYPE_PRECISION (string_type_node))
12107     /* ASSIGN 10 TO I will crash.  */
12108     warning ("configuration: char * holds %d bits, but INTEGER only %d --\n\
12109  ASSIGN statement might fail",
12110              TYPE_PRECISION (string_type_node),
12111              TYPE_PRECISION (ffecom_integer_type_node));
12112 #endif
12113 }
12114
12115 #endif
12116 /* ffecom_init_2 -- Initialize
12117
12118    ffecom_init_2();  */
12119
12120 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12121 void
12122 ffecom_init_2 ()
12123 {
12124   assert (ffecom_outer_function_decl_ == NULL_TREE);
12125   assert (current_function_decl == NULL_TREE);
12126   assert (ffecom_which_entrypoint_decl_ == NULL_TREE);
12127
12128   ffecom_master_arglist_ = NULL;
12129   ++ffecom_num_fns_;
12130   ffecom_primary_entry_ = NULL;
12131   ffecom_is_altreturning_ = FALSE;
12132   ffecom_func_result_ = NULL_TREE;
12133   ffecom_multi_retval_ = NULL_TREE;
12134 }
12135
12136 #endif
12137 /* ffecom_list_expr -- Transform list of exprs into gcc tree
12138
12139    tree t;
12140    ffebld expr;  // FFE opITEM list.
12141    tree = ffecom_list_expr(expr);
12142
12143    List of actual args is transformed into corresponding gcc backend list.  */
12144
12145 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12146 tree
12147 ffecom_list_expr (ffebld expr)
12148 {
12149   tree list;
12150   tree *plist = &list;
12151   tree trail = NULL_TREE;       /* Append char length args here. */
12152   tree *ptrail = &trail;
12153   tree length;
12154
12155   while (expr != NULL)
12156     {
12157       tree texpr = ffecom_arg_expr (ffebld_head (expr), &length);
12158
12159       if (texpr == error_mark_node)
12160         return error_mark_node;
12161
12162       *plist = build_tree_list (NULL_TREE, texpr);
12163       plist = &TREE_CHAIN (*plist);
12164       expr = ffebld_trail (expr);
12165       if (length != NULL_TREE)
12166         {
12167           *ptrail = build_tree_list (NULL_TREE, length);
12168           ptrail = &TREE_CHAIN (*ptrail);
12169         }
12170     }
12171
12172   *plist = trail;
12173
12174   return list;
12175 }
12176
12177 #endif
12178 /* ffecom_list_ptr_to_expr -- Transform list of exprs into gcc tree
12179
12180    tree t;
12181    ffebld expr;  // FFE opITEM list.
12182    tree = ffecom_list_ptr_to_expr(expr);
12183
12184    List of actual args is transformed into corresponding gcc backend list for
12185    use in calling an external procedure (vs. a statement function).  */
12186
12187 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12188 tree
12189 ffecom_list_ptr_to_expr (ffebld expr)
12190 {
12191   tree list;
12192   tree *plist = &list;
12193   tree trail = NULL_TREE;       /* Append char length args here. */
12194   tree *ptrail = &trail;
12195   tree length;
12196
12197   while (expr != NULL)
12198     {
12199       tree texpr = ffecom_arg_ptr_to_expr (ffebld_head (expr), &length);
12200
12201       if (texpr == error_mark_node)
12202         return error_mark_node;
12203
12204       *plist = build_tree_list (NULL_TREE, texpr);
12205       plist = &TREE_CHAIN (*plist);
12206       expr = ffebld_trail (expr);
12207       if (length != NULL_TREE)
12208         {
12209           *ptrail = build_tree_list (NULL_TREE, length);
12210           ptrail = &TREE_CHAIN (*ptrail);
12211         }
12212     }
12213
12214   *plist = trail;
12215
12216   return list;
12217 }
12218
12219 #endif
12220 /* Obtain gcc's LABEL_DECL tree for label.  */
12221
12222 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12223 tree
12224 ffecom_lookup_label (ffelab label)
12225 {
12226   tree glabel;
12227
12228   if (ffelab_hook (label) == NULL_TREE)
12229     {
12230       char labelname[16];
12231
12232       switch (ffelab_type (label))
12233         {
12234         case FFELAB_typeLOOPEND:
12235         case FFELAB_typeNOTLOOP:
12236         case FFELAB_typeENDIF:
12237           sprintf (labelname, "%" ffelabValue_f "u", ffelab_value (label));
12238           glabel = build_decl (LABEL_DECL, get_identifier (labelname),
12239                                void_type_node);
12240           DECL_CONTEXT (glabel) = current_function_decl;
12241           DECL_MODE (glabel) = VOIDmode;
12242           break;
12243
12244         case FFELAB_typeFORMAT:
12245           glabel = build_decl (VAR_DECL,
12246                                ffecom_get_invented_identifier
12247                                ("__g77_format_%d", (int) ffelab_value (label)),
12248                                build_type_variant (build_array_type
12249                                                    (char_type_node,
12250                                                     NULL_TREE),
12251                                                    1, 0));
12252           TREE_CONSTANT (glabel) = 1;
12253           TREE_STATIC (glabel) = 1;
12254           DECL_CONTEXT (glabel) = current_function_decl;
12255           DECL_INITIAL (glabel) = NULL;
12256           make_decl_rtl (glabel, NULL);
12257           expand_decl (glabel);
12258
12259           ffecom_save_tree_forever (glabel);
12260
12261           break;
12262
12263         case FFELAB_typeANY:
12264           glabel = error_mark_node;
12265           break;
12266
12267         default:
12268           assert ("bad label type" == NULL);
12269           glabel = NULL;
12270           break;
12271         }
12272       ffelab_set_hook (label, glabel);
12273     }
12274   else
12275     {
12276       glabel = ffelab_hook (label);
12277     }
12278
12279   return glabel;
12280 }
12281
12282 #endif
12283 /* Stabilizes the arguments.  Don't use this if the lhs and rhs come from
12284    a single source specification (as in the fourth argument of MVBITS).
12285    If the type is NULL_TREE, the type of lhs is used to make the type of
12286    the MODIFY_EXPR.  */
12287
12288 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12289 tree
12290 ffecom_modify (tree newtype, tree lhs,
12291                tree rhs)
12292 {
12293   if (lhs == error_mark_node || rhs == error_mark_node)
12294     return error_mark_node;
12295
12296   if (newtype == NULL_TREE)
12297     newtype = TREE_TYPE (lhs);
12298
12299   if (TREE_SIDE_EFFECTS (lhs))
12300     lhs = stabilize_reference (lhs);
12301
12302   return ffecom_2s (MODIFY_EXPR, newtype, lhs, rhs);
12303 }
12304
12305 #endif
12306
12307 /* Register source file name.  */
12308
12309 void
12310 ffecom_file (const char *name)
12311 {
12312 #if FFECOM_GCC_INCLUDE
12313   ffecom_file_ (name);
12314 #endif
12315 }
12316
12317 /* ffecom_notify_init_storage -- An aggregate storage is now fully init'ed
12318
12319    ffestorag st;
12320    ffecom_notify_init_storage(st);
12321
12322    Gets called when all possible units in an aggregate storage area (a LOCAL
12323    with equivalences or a COMMON) have been initialized.  The initialization
12324    info either is in ffestorag_init or, if that is NULL,
12325    ffestorag_accretion:
12326
12327    ffestorag_init may contain an opCONTER or opARRTER.  opCONTER may occur
12328    even for an array if the array is one element in length!
12329
12330    ffestorag_accretion will contain an opACCTER.  It is much like an
12331    opARRTER except it has an ffebit object in it instead of just a size.
12332    The back end can use the info in the ffebit object, if it wants, to
12333    reduce the amount of actual initialization, but in any case it should
12334    kill the ffebit object when done.  Also, set accretion to NULL but
12335    init to a non-NULL value.
12336
12337    After performing initialization, DO NOT set init to NULL, because that'll
12338    tell the front end it is ok for more initialization to happen.  Instead,
12339    set init to an opANY expression or some such thing that you can use to
12340    tell that you've already initialized the object.
12341
12342    27-Oct-91  JCB  1.1
12343       Support two-pass FFE.  */
12344
12345 void
12346 ffecom_notify_init_storage (ffestorag st)
12347 {
12348   ffebld init;                  /* The initialization expression. */
12349 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12350   ffetargetOffset size;         /* The size of the entity. */
12351   ffetargetAlign pad;           /* Its initial padding. */
12352 #endif
12353
12354   if (ffestorag_init (st) == NULL)
12355     {
12356       init = ffestorag_accretion (st);
12357       assert (init != NULL);
12358       ffestorag_set_accretion (st, NULL);
12359       ffestorag_set_accretes (st, 0);
12360
12361 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12362       /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12363       size = ffebld_accter_size (init);
12364       pad = ffebld_accter_pad (init);
12365       ffebit_kill (ffebld_accter_bits (init));
12366       ffebld_set_op (init, FFEBLD_opARRTER);
12367       ffebld_set_arrter (init, ffebld_accter (init));
12368       ffebld_arrter_set_size (init, size);
12369       ffebld_arrter_set_pad (init, size);
12370 #endif
12371
12372 #if FFECOM_TWOPASS
12373       ffestorag_set_init (st, init);
12374 #endif
12375     }
12376 #if FFECOM_ONEPASS
12377   else
12378     init = ffestorag_init (st);
12379 #endif
12380
12381 #if FFECOM_ONEPASS              /* Process the inits, wipe 'em out. */
12382   ffestorag_set_init (st, ffebld_new_any ());
12383
12384   if (ffebld_op (init) == FFEBLD_opANY)
12385     return;                     /* Oh, we already did this! */
12386
12387 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12388   {
12389     ffesymbol s;
12390
12391     if (ffestorag_symbol (st) != NULL)
12392       s = ffestorag_symbol (st);
12393     else
12394       s = ffestorag_typesymbol (st);
12395
12396     fprintf (dmpout, "= initialize_storage \"%s\" ",
12397              (s != NULL) ? ffesymbol_text (s) : "(unnamed)");
12398     ffebld_dump (init);
12399     fputc ('\n', dmpout);
12400   }
12401 #endif
12402
12403 #endif /* if FFECOM_ONEPASS */
12404 }
12405
12406 /* ffecom_notify_init_symbol -- A symbol is now fully init'ed
12407
12408    ffesymbol s;
12409    ffecom_notify_init_symbol(s);
12410
12411    Gets called when all possible units in a symbol (not placed in COMMON
12412    or involved in EQUIVALENCE, unless it as yet has no ffestorag object)
12413    have been initialized.  The initialization info either is in
12414    ffesymbol_init or, if that is NULL, ffesymbol_accretion:
12415
12416    ffesymbol_init may contain an opCONTER or opARRTER.  opCONTER may occur
12417    even for an array if the array is one element in length!
12418
12419    ffesymbol_accretion will contain an opACCTER.  It is much like an
12420    opARRTER except it has an ffebit object in it instead of just a size.
12421    The back end can use the info in the ffebit object, if it wants, to
12422    reduce the amount of actual initialization, but in any case it should
12423    kill the ffebit object when done.  Also, set accretion to NULL but
12424    init to a non-NULL value.
12425
12426    After performing initialization, DO NOT set init to NULL, because that'll
12427    tell the front end it is ok for more initialization to happen.  Instead,
12428    set init to an opANY expression or some such thing that you can use to
12429    tell that you've already initialized the object.
12430
12431    27-Oct-91  JCB  1.1
12432       Support two-pass FFE.  */
12433
12434 void
12435 ffecom_notify_init_symbol (ffesymbol s)
12436 {
12437   ffebld init;                  /* The initialization expression. */
12438 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12439   ffetargetOffset size;         /* The size of the entity. */
12440   ffetargetAlign pad;           /* Its initial padding. */
12441 #endif
12442
12443   if (ffesymbol_storage (s) == NULL)
12444     return;                     /* Do nothing until COMMON/EQUIVALENCE
12445                                    possibilities checked. */
12446
12447   if ((ffesymbol_init (s) == NULL)
12448       && ((init = ffesymbol_accretion (s)) != NULL))
12449     {
12450       ffesymbol_set_accretion (s, NULL);
12451       ffesymbol_set_accretes (s, 0);
12452
12453 #if 0 && FFECOM_targetCURRENT == FFECOM_targetGCC
12454       /* For GNU backend, just turn ACCTER into ARRTER and proceed. */
12455       size = ffebld_accter_size (init);
12456       pad = ffebld_accter_pad (init);
12457       ffebit_kill (ffebld_accter_bits (init));
12458       ffebld_set_op (init, FFEBLD_opARRTER);
12459       ffebld_set_arrter (init, ffebld_accter (init));
12460       ffebld_arrter_set_size (init, size);
12461       ffebld_arrter_set_pad (init, size);
12462 #endif
12463
12464 #if FFECOM_TWOPASS
12465       ffesymbol_set_init (s, init);
12466 #endif
12467     }
12468 #if FFECOM_ONEPASS
12469   else
12470     init = ffesymbol_init (s);
12471 #endif
12472
12473 #if FFECOM_ONEPASS
12474   ffesymbol_set_init (s, ffebld_new_any ());
12475
12476   if (ffebld_op (init) == FFEBLD_opANY)
12477     return;                     /* Oh, we already did this! */
12478
12479 #if FFECOM_targetCURRENT == FFECOM_targetFFE
12480   fprintf (dmpout, "= initialize_symbol \"%s\" ", ffesymbol_text (s));
12481   ffebld_dump (init);
12482   fputc ('\n', dmpout);
12483 #endif
12484
12485 #endif /* if FFECOM_ONEPASS */
12486 }
12487
12488 /* ffecom_notify_primary_entry -- Learn which is the primary entry point
12489
12490    ffesymbol s;
12491    ffecom_notify_primary_entry(s);
12492
12493    Gets called when implicit or explicit PROGRAM statement seen or when
12494    FUNCTION, SUBROUTINE, or BLOCK DATA statement seen, with the primary
12495    global symbol that serves as the entry point.  */
12496
12497 void
12498 ffecom_notify_primary_entry (ffesymbol s)
12499 {
12500   ffecom_primary_entry_ = s;
12501   ffecom_primary_entry_kind_ = ffesymbol_kind (s);
12502
12503   if ((ffecom_primary_entry_kind_ == FFEINFO_kindFUNCTION)
12504       || (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE))
12505     ffecom_primary_entry_is_proc_ = TRUE;
12506   else
12507     ffecom_primary_entry_is_proc_ = FALSE;
12508
12509   if (!ffe_is_silent ())
12510     {
12511       if (ffecom_primary_entry_kind_ == FFEINFO_kindPROGRAM)
12512         fprintf (stderr, "%s:\n", ffesymbol_text (s));
12513       else
12514         fprintf (stderr, "  %s:\n", ffesymbol_text (s));
12515     }
12516
12517 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12518   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE)
12519     {
12520       ffebld list;
12521       ffebld arg;
12522
12523       for (list = ffesymbol_dummyargs (s);
12524            list != NULL;
12525            list = ffebld_trail (list))
12526         {
12527           arg = ffebld_head (list);
12528           if (ffebld_op (arg) == FFEBLD_opSTAR)
12529             {
12530               ffecom_is_altreturning_ = TRUE;
12531               break;
12532             }
12533         }
12534     }
12535 #endif
12536 }
12537
12538 FILE *
12539 ffecom_open_include (char *name, ffewhereLine l, ffewhereColumn c)
12540 {
12541 #if FFECOM_GCC_INCLUDE
12542   return ffecom_open_include_ (name, l, c);
12543 #else
12544   return fopen (name, "r");
12545 #endif
12546 }
12547
12548 /* ffecom_ptr_to_expr -- Transform expr into gcc tree with & in front
12549
12550    tree t;
12551    ffebld expr;  // FFE expression.
12552    tree = ffecom_ptr_to_expr(expr);
12553
12554    Like ffecom_expr, but sticks address-of in front of most things.  */
12555
12556 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12557 tree
12558 ffecom_ptr_to_expr (ffebld expr)
12559 {
12560   tree item;
12561   ffeinfoBasictype bt;
12562   ffeinfoKindtype kt;
12563   ffesymbol s;
12564
12565   assert (expr != NULL);
12566
12567   switch (ffebld_op (expr))
12568     {
12569     case FFEBLD_opSYMTER:
12570       s = ffebld_symter (expr);
12571       if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
12572         {
12573           ffecomGfrt ix;
12574
12575           ix = ffeintrin_gfrt_indirect (ffebld_symter_implementation (expr));
12576           assert (ix != FFECOM_gfrt);
12577           if ((item = ffecom_gfrt_[ix]) == NULL_TREE)
12578             {
12579               ffecom_make_gfrt_ (ix);
12580               item = ffecom_gfrt_[ix];
12581             }
12582         }
12583       else
12584         {
12585           item = ffesymbol_hook (s).decl_tree;
12586           if (item == NULL_TREE)
12587             {
12588               s = ffecom_sym_transform_ (s);
12589               item = ffesymbol_hook (s).decl_tree;
12590             }
12591         }
12592       assert (item != NULL);
12593       if (item == error_mark_node)
12594         return item;
12595       if (!ffesymbol_hook (s).addr)
12596         item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12597                          item);
12598       return item;
12599
12600     case FFEBLD_opARRAYREF:
12601       return ffecom_arrayref_ (NULL_TREE, expr, 1);
12602
12603     case FFEBLD_opCONTER:
12604
12605       bt = ffeinfo_basictype (ffebld_info (expr));
12606       kt = ffeinfo_kindtype (ffebld_info (expr));
12607
12608       item = ffecom_constantunion (&ffebld_constant_union
12609                                    (ffebld_conter (expr)), bt, kt,
12610                                    ffecom_tree_type[bt][kt]);
12611       if (item == error_mark_node)
12612         return error_mark_node;
12613       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12614                        item);
12615       return item;
12616
12617     case FFEBLD_opANY:
12618       return error_mark_node;
12619
12620     default:
12621       bt = ffeinfo_basictype (ffebld_info (expr));
12622       kt = ffeinfo_kindtype (ffebld_info (expr));
12623
12624       item = ffecom_expr (expr);
12625       if (item == error_mark_node)
12626         return error_mark_node;
12627
12628       /* The back end currently optimizes a bit too zealously for us, in that
12629          we fail JCB001 if the following block of code is omitted.  It checks
12630          to see if the transformed expression is a symbol or array reference,
12631          and encloses it in a SAVE_EXPR if that is the case.  */
12632
12633       STRIP_NOPS (item);
12634       if ((TREE_CODE (item) == VAR_DECL)
12635           || (TREE_CODE (item) == PARM_DECL)
12636           || (TREE_CODE (item) == RESULT_DECL)
12637           || (TREE_CODE (item) == INDIRECT_REF)
12638           || (TREE_CODE (item) == ARRAY_REF)
12639           || (TREE_CODE (item) == COMPONENT_REF)
12640 #ifdef OFFSET_REF
12641           || (TREE_CODE (item) == OFFSET_REF)
12642 #endif
12643           || (TREE_CODE (item) == BUFFER_REF)
12644           || (TREE_CODE (item) == REALPART_EXPR)
12645           || (TREE_CODE (item) == IMAGPART_EXPR))
12646         {
12647           item = ffecom_save_tree (item);
12648         }
12649
12650       item = ffecom_1 (ADDR_EXPR, build_pointer_type (TREE_TYPE (item)),
12651                        item);
12652       return item;
12653     }
12654
12655   assert ("fall-through error" == NULL);
12656   return error_mark_node;
12657 }
12658
12659 #endif
12660 /* Obtain a temp var with given data type.
12661
12662    size is FFETARGET_charactersizeNONE for a non-CHARACTER type
12663    or >= 0 for a CHARACTER type.
12664
12665    elements is -1 for a scalar or > 0 for an array of type.  */
12666
12667 #if FFECOM_targetCURRENT == FFECOM_targetGCC
12668 tree
12669 ffecom_make_tempvar (const char *commentary, tree type,
12670                      ffetargetCharacterSize size, int elements)
12671 {
12672   tree t;
12673   static int mynumber;
12674
12675   assert (current_binding_level->prep_state < 2);
12676
12677   if (type == error_mark_node)
12678     return error_mark_node;
12679
12680   if (size != FFETARGET_charactersizeNONE)
12681     type = build_array_type (type,
12682                              build_range_type (ffecom_f2c_ftnlen_type_node,
12683                                                ffecom_f2c_ftnlen_one_node,
12684                                                build_int_2 (size, 0)));
12685   if (elements != -1)
12686     type = build_array_type (type,
12687                              build_range_type (integer_type_node,
12688                                                integer_zero_node,
12689                                                build_int_2 (elements - 1,
12690                                                             0)));
12691   t = build_decl (VAR_DECL,
12692                   ffecom_get_invented_identifier ("__g77_%s_%d",
12693                                                   commentary,
12694                                                   mynumber++),
12695                   type);
12696
12697   t = start_decl (t, FALSE);
12698   finish_decl (t, NULL_TREE, FALSE);
12699
12700   return t;
12701 }
12702 #endif
12703
12704 /* Prepare argument pointer to expression.
12705
12706    Like ffecom_prepare_expr, except for expressions to be evaluated
12707    via ffecom_arg_ptr_to_expr.  */
12708
12709 void
12710 ffecom_prepare_arg_ptr_to_expr (ffebld expr)
12711 {
12712   /* ~~For now, it seems to be the same thing.  */
12713   ffecom_prepare_expr (expr);
12714   return;
12715 }
12716
12717 /* End of preparations.  */
12718
12719 bool
12720 ffecom_prepare_end (void)
12721 {
12722   int prep_state = current_binding_level->prep_state;
12723
12724   assert (prep_state < 2);
12725   current_binding_level->prep_state = 2;
12726
12727   return (prep_state == 1) ? TRUE : FALSE;
12728 }
12729
12730 /* Prepare expression.
12731
12732    This is called before any code is generated for the current block.
12733    It scans the expression, declares any temporaries that might be needed
12734    during evaluation of the expression, and stores those temporaries in
12735    the appropriate "hook" fields of the expression.  `dest', if not NULL,
12736    specifies the destination that ffecom_expr_ will see, in case that
12737    helps avoid generating unused temporaries.
12738
12739    ~~Improve to avoid allocating unused temporaries by taking `dest'
12740    into account vis-a-vis aliasing requirements of complex/character
12741    functions.  */
12742
12743 void
12744 ffecom_prepare_expr_ (ffebld expr, ffebld dest UNUSED)
12745 {
12746   ffeinfoBasictype bt;
12747   ffeinfoKindtype kt;
12748   ffetargetCharacterSize sz;
12749   tree tempvar = NULL_TREE;
12750
12751   assert (current_binding_level->prep_state < 2);
12752
12753   if (! expr)
12754     return;
12755
12756   bt = ffeinfo_basictype (ffebld_info (expr));
12757   kt = ffeinfo_kindtype (ffebld_info (expr));
12758   sz = ffeinfo_size (ffebld_info (expr));
12759
12760   /* Generate whatever temporaries are needed to represent the result
12761      of the expression.  */
12762
12763   if (bt == FFEINFO_basictypeCHARACTER)
12764     {
12765       while (ffebld_op (expr) == FFEBLD_opPAREN)
12766         expr = ffebld_left (expr);
12767     }
12768
12769   switch (ffebld_op (expr))
12770     {
12771     default:
12772       /* Don't make temps for SYMTER, CONTER, etc.  */
12773       if (ffebld_arity (expr) == 0)
12774         break;
12775
12776       switch (bt)
12777         {
12778         case FFEINFO_basictypeCOMPLEX:
12779           if (ffebld_op (expr) == FFEBLD_opFUNCREF)
12780             {
12781               ffesymbol s;
12782
12783               if (ffebld_op (ffebld_left (expr)) != FFEBLD_opSYMTER)
12784                 break;
12785
12786               s = ffebld_symter (ffebld_left (expr));
12787               if (ffesymbol_where (s) == FFEINFO_whereCONSTANT
12788                   || (ffesymbol_where (s) != FFEINFO_whereINTRINSIC
12789                       && ! ffesymbol_is_f2c (s))
12790                   || (ffesymbol_where (s) == FFEINFO_whereINTRINSIC
12791                       && ! ffe_is_f2c_library ()))
12792                 break;
12793             }
12794           else if (ffebld_op (expr) == FFEBLD_opPOWER)
12795             {
12796               /* Requires special treatment.  There's no POW_CC function
12797                  in libg2c, so POW_ZZ is used, which means we always
12798                  need a double-complex temp, not a single-complex.  */
12799               kt = FFEINFO_kindtypeREAL2;
12800             }
12801           else if (ffebld_op (expr) != FFEBLD_opDIVIDE)
12802             /* The other ops don't need temps for complex operands.  */
12803             break;
12804
12805           /* ~~~Avoid making temps for some intrinsics, such as AIMAG(C),
12806              REAL(C).  See 19990325-0.f, routine `check', for cases.  */
12807           tempvar = ffecom_make_tempvar ("complex",
12808                                          ffecom_tree_type
12809                                          [FFEINFO_basictypeCOMPLEX][kt],
12810                                          FFETARGET_charactersizeNONE,
12811                                          -1);
12812           break;
12813
12814         case FFEINFO_basictypeCHARACTER:
12815           if (ffebld_op (expr) != FFEBLD_opFUNCREF)
12816             break;
12817
12818           if (sz == FFETARGET_charactersizeNONE)
12819             /* ~~Kludge alert!  This should someday be fixed. */
12820             sz = 24;
12821
12822           tempvar = ffecom_make_tempvar ("char", char_type_node, sz, -1);
12823           break;
12824
12825         default:
12826           break;
12827         }
12828       break;
12829
12830 #ifdef HAHA
12831     case FFEBLD_opPOWER:
12832       {
12833         tree rtype, ltype;
12834         tree rtmp, ltmp, result;
12835
12836         ltype = ffecom_type_expr (ffebld_left (expr));
12837         rtype = ffecom_type_expr (ffebld_right (expr));
12838
12839         rtmp = ffecom_make_tempvar (rtype, FFETARGET_charactersizeNONE, -1);
12840         ltmp = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12841         result = ffecom_make_tempvar (ltype, FFETARGET_charactersizeNONE, -1);
12842
12843         tempvar = make_tree_vec (3);
12844         TREE_VEC_ELT (tempvar, 0) = rtmp;
12845         TREE_VEC_ELT (tempvar, 1) = ltmp;
12846         TREE_VEC_ELT (tempvar, 2) = result;
12847       }
12848       break;
12849 #endif  /* HAHA */
12850
12851     case FFEBLD_opCONCATENATE:
12852       {
12853         /* This gets special handling, because only one set of temps
12854            is needed for a tree of these -- the tree is treated as
12855            a flattened list of concatenations when generating code.  */
12856
12857         ffecomConcatList_ catlist;
12858         tree ltmp, itmp, result;
12859         int count;
12860         int i;
12861
12862         catlist = ffecom_concat_list_new_ (expr, FFETARGET_charactersizeNONE);
12863         count = ffecom_concat_list_count_ (catlist);
12864
12865         if (count >= 2)
12866           {
12867             ltmp
12868               = ffecom_make_tempvar ("concat_len",
12869                                      ffecom_f2c_ftnlen_type_node,
12870                                      FFETARGET_charactersizeNONE, count);
12871             itmp
12872               = ffecom_make_tempvar ("concat_item",
12873                                      ffecom_f2c_address_type_node,
12874                                      FFETARGET_charactersizeNONE, count);
12875             result
12876               = ffecom_make_tempvar ("concat_res",
12877                                      char_type_node,
12878                                      ffecom_concat_list_maxlen_ (catlist),
12879                                      -1);
12880
12881             tempvar = make_tree_vec (3);
12882             TREE_VEC_ELT (tempvar, 0) = ltmp;
12883             TREE_VEC_ELT (tempvar, 1) = itmp;
12884             TREE_VEC_ELT (tempvar, 2) = result;
12885           }
12886
12887         for (i = 0; i < count; ++i)
12888           ffecom_prepare_arg_ptr_to_expr (ffecom_concat_list_expr_ (catlist,
12889                                                                     i));
12890
12891         ffecom_concat_list_kill_ (catlist);
12892
12893         if (tempvar)
12894           {
12895             ffebld_nonter_set_hook (expr, tempvar);
12896             current_binding_level->prep_state = 1;
12897           }
12898       }
12899       return;
12900
12901     case FFEBLD_opCONVERT:
12902       if (bt == FFEINFO_basictypeCHARACTER
12903           && ((ffebld_size_known (ffebld_left (expr))
12904                == FFETARGET_charactersizeNONE)
12905               || (ffebld_size_known (ffebld_left (expr)) >= sz)))
12906         tempvar = ffecom_make_tempvar ("convert", char_type_node, sz, -1);
12907       break;
12908     }
12909
12910   if (tempvar)
12911     {
12912       ffebld_nonter_set_hook (expr, tempvar);
12913       current_binding_level->prep_state = 1;
12914     }
12915
12916   /* Prepare subexpressions for this expr.  */
12917
12918   switch (ffebld_op (expr))
12919     {
12920     case FFEBLD_opPERCENT_LOC:
12921       ffecom_prepare_ptr_to_expr (ffebld_left (expr));
12922       break;
12923
12924     case FFEBLD_opPERCENT_VAL:
12925     case FFEBLD_opPERCENT_REF:
12926       ffecom_prepare_expr (ffebld_left (expr));
12927       break;
12928
12929     case FFEBLD_opPERCENT_DESCR:
12930       ffecom_prepare_arg_ptr_to_expr (ffebld_left (expr));
12931       break;
12932
12933     case FFEBLD_opITEM:
12934       {
12935         ffebld item;
12936
12937         for (item = expr;
12938              item != NULL;
12939              item = ffebld_trail (item))
12940           if (ffebld_head (item) != NULL)
12941             ffecom_prepare_expr (ffebld_head (item));
12942       }
12943       break;
12944
12945     default:
12946       /* Need to handle character conversion specially.  */
12947       switch (ffebld_arity (expr))
12948         {
12949         case 2:
12950           ffecom_prepare_expr (ffebld_left (expr));
12951           ffecom_prepare_expr (ffebld_right (expr));
12952           break;
12953
12954         case 1:
12955           ffecom_prepare_expr (ffebld_left (expr));
12956           break;
12957
12958         default:
12959           break;
12960         }
12961     }
12962
12963   return;
12964 }
12965
12966 /* Prepare expression for reading and writing.
12967
12968    Like ffecom_prepare_expr, except for expressions to be evaluated
12969    via ffecom_expr_rw.  */
12970
12971 void
12972 ffecom_prepare_expr_rw (tree type, ffebld expr)
12973 {
12974   /* This is all we support for now.  */
12975   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
12976
12977   /* ~~For now, it seems to be the same thing.  */
12978   ffecom_prepare_expr (expr);
12979   return;
12980 }
12981
12982 /* Prepare expression for writing.
12983
12984    Like ffecom_prepare_expr, except for expressions to be evaluated
12985    via ffecom_expr_w.  */
12986
12987 void
12988 ffecom_prepare_expr_w (tree type, ffebld expr)
12989 {
12990   /* This is all we support for now.  */
12991   assert (type == NULL_TREE || type == ffecom_type_expr (expr));
12992
12993   /* ~~For now, it seems to be the same thing.  */
12994   ffecom_prepare_expr (expr);
12995   return;
12996 }
12997
12998 /* Prepare expression for returning.
12999
13000    Like ffecom_prepare_expr, except for expressions to be evaluated
13001    via ffecom_return_expr.  */
13002
13003 void
13004 ffecom_prepare_return_expr (ffebld expr)
13005 {
13006   assert (current_binding_level->prep_state < 2);
13007
13008   if (ffecom_primary_entry_kind_ == FFEINFO_kindSUBROUTINE
13009       && ffecom_is_altreturning_
13010       && expr != NULL)
13011     ffecom_prepare_expr (expr);
13012 }
13013
13014 /* Prepare pointer to expression.
13015
13016    Like ffecom_prepare_expr, except for expressions to be evaluated
13017    via ffecom_ptr_to_expr.  */
13018
13019 void
13020 ffecom_prepare_ptr_to_expr (ffebld expr)
13021 {
13022   /* ~~For now, it seems to be the same thing.  */
13023   ffecom_prepare_expr (expr);
13024   return;
13025 }
13026
13027 /* Transform expression into constant pointer-to-expression tree.
13028
13029    If the expression can be transformed into a pointer-to-expression tree
13030    that is constant, that is done, and the tree returned.  Else NULL_TREE
13031    is returned.
13032
13033    That way, a caller can attempt to provide compile-time initialization
13034    of a variable and, if that fails, *then* choose to start a new block
13035    and resort to using temporaries, as appropriate.  */
13036
13037 tree
13038 ffecom_ptr_to_const_expr (ffebld expr)
13039 {
13040   if (! expr)
13041     return integer_zero_node;
13042
13043   if (ffebld_op (expr) == FFEBLD_opANY)
13044     return error_mark_node;
13045
13046   if (ffebld_arity (expr) == 0
13047       && (ffebld_op (expr) != FFEBLD_opSYMTER
13048           || ffebld_where (expr) == FFEINFO_whereCOMMON
13049           || ffebld_where (expr) == FFEINFO_whereGLOBAL
13050           || ffebld_where (expr) == FFEINFO_whereINTRINSIC))
13051     {
13052       tree t;
13053
13054       t = ffecom_ptr_to_expr (expr);
13055       assert (TREE_CONSTANT (t));
13056       return t;
13057     }
13058
13059   return NULL_TREE;
13060 }
13061
13062 /* ffecom_return_expr -- Returns return-value expr given alt return expr
13063
13064    tree rtn;  // NULL_TREE means use expand_null_return()
13065    ffebld expr;  // NULL if no alt return expr to RETURN stmt
13066    rtn = ffecom_return_expr(expr);
13067
13068    Based on the program unit type and other info (like return function
13069    type, return master function type when alternate ENTRY points,
13070    whether subroutine has any alternate RETURN points, etc), returns the
13071    appropriate expression to be returned to the caller, or NULL_TREE
13072    meaning no return value or the caller expects it to be returned somewhere
13073    else (which is handled by other parts of this module).  */
13074
13075 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13076 tree
13077 ffecom_return_expr (ffebld expr)
13078 {
13079   tree rtn;
13080
13081   switch (ffecom_primary_entry_kind_)
13082     {
13083     case FFEINFO_kindPROGRAM:
13084     case FFEINFO_kindBLOCKDATA:
13085       rtn = NULL_TREE;
13086       break;
13087
13088     case FFEINFO_kindSUBROUTINE:
13089       if (!ffecom_is_altreturning_)
13090         rtn = NULL_TREE;        /* No alt returns, never an expr. */
13091       else if (expr == NULL)
13092         rtn = integer_zero_node;
13093       else
13094         rtn = ffecom_expr (expr);
13095       break;
13096
13097     case FFEINFO_kindFUNCTION:
13098       if ((ffecom_multi_retval_ != NULL_TREE)
13099           || (ffesymbol_basictype (ffecom_primary_entry_)
13100               == FFEINFO_basictypeCHARACTER)
13101           || ((ffesymbol_basictype (ffecom_primary_entry_)
13102                == FFEINFO_basictypeCOMPLEX)
13103               && (ffecom_num_entrypoints_ == 0)
13104               && ffesymbol_is_f2c (ffecom_primary_entry_)))
13105         {                       /* Value is returned by direct assignment
13106                                    into (implicit) dummy. */
13107           rtn = NULL_TREE;
13108           break;
13109         }
13110       rtn = ffecom_func_result_;
13111 #if 0
13112       /* Spurious error if RETURN happens before first reference!  So elide
13113          this code.  In particular, for debugging registry, rtn should always
13114          be non-null after all, but TREE_USED won't be set until we encounter
13115          a reference in the code.  Perfectly okay (but weird) code that,
13116          e.g., has "GOTO 20;10 RETURN;20 RTN=0;GOTO 10", would result in
13117          this diagnostic for no reason.  Have people use -O -Wuninitialized
13118          and leave it to the back end to find obviously weird cases.  */
13119
13120       /* Used to "assert(rtn != NULL_TREE);" here, but it's kind of a valid
13121          situation; if the return value has never been referenced, it won't
13122          have a tree under 2pass mode. */
13123       if ((rtn == NULL_TREE)
13124           || !TREE_USED (rtn))
13125         {
13126           ffebad_start (FFEBAD_RETURN_VALUE_UNSET);
13127           ffebad_here (0, ffesymbol_where_line (ffecom_primary_entry_),
13128                        ffesymbol_where_column (ffecom_primary_entry_));
13129           ffebad_string (ffesymbol_text (ffesymbol_funcresult
13130                                          (ffecom_primary_entry_)));
13131           ffebad_finish ();
13132         }
13133 #endif
13134       break;
13135
13136     default:
13137       assert ("bad unit kind" == NULL);
13138     case FFEINFO_kindANY:
13139       rtn = error_mark_node;
13140       break;
13141     }
13142
13143   return rtn;
13144 }
13145
13146 #endif
13147 /* Do save_expr only if tree is not error_mark_node.  */
13148
13149 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13150 tree
13151 ffecom_save_tree (tree t)
13152 {
13153   return save_expr (t);
13154 }
13155 #endif
13156
13157 /* Start a compound statement (block).  */
13158
13159 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13160 void
13161 ffecom_start_compstmt (void)
13162 {
13163   bison_rule_pushlevel_ ();
13164 }
13165 #endif  /* FFECOM_targetCURRENT == FFECOM_targetGCC */
13166
13167 /* Public entry point for front end to access start_decl.  */
13168
13169 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13170 tree
13171 ffecom_start_decl (tree decl, bool is_initialized)
13172 {
13173   DECL_INITIAL (decl) = is_initialized ? error_mark_node : NULL_TREE;
13174   return start_decl (decl, FALSE);
13175 }
13176
13177 #endif
13178 /* ffecom_sym_commit -- Symbol's state being committed to reality
13179
13180    ffesymbol s;
13181    ffecom_sym_commit(s);
13182
13183    Does whatever the backend needs when a symbol is committed after having
13184    been backtrackable for a period of time.  */
13185
13186 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13187 void
13188 ffecom_sym_commit (ffesymbol s UNUSED)
13189 {
13190   assert (!ffesymbol_retractable ());
13191 }
13192
13193 #endif
13194 /* ffecom_sym_end_transition -- Perform end transition on all symbols
13195
13196    ffecom_sym_end_transition();
13197
13198    Does backend-specific stuff and also calls ffest_sym_end_transition
13199    to do the necessary FFE stuff.
13200
13201    Backtracking is never enabled when this fn is called, so don't worry
13202    about it.  */
13203
13204 ffesymbol
13205 ffecom_sym_end_transition (ffesymbol s)
13206 {
13207   ffestorag st;
13208
13209   assert (!ffesymbol_retractable ());
13210
13211   s = ffest_sym_end_transition (s);
13212
13213 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13214   if ((ffesymbol_kind (s) == FFEINFO_kindBLOCKDATA)
13215       && (ffesymbol_where (s) == FFEINFO_whereGLOBAL))
13216     {
13217       ffecom_list_blockdata_
13218         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
13219                                               FFEINTRIN_specNONE,
13220                                               FFEINTRIN_impNONE),
13221                            ffecom_list_blockdata_);
13222     }
13223 #endif
13224
13225   /* This is where we finally notice that a symbol has partial initialization
13226      and finalize it. */
13227
13228   if (ffesymbol_accretion (s) != NULL)
13229     {
13230       assert (ffesymbol_init (s) == NULL);
13231       ffecom_notify_init_symbol (s);
13232     }
13233   else if (((st = ffesymbol_storage (s)) != NULL)
13234            && ((st = ffestorag_parent (st)) != NULL)
13235            && (ffestorag_accretion (st) != NULL))
13236     {
13237       assert (ffestorag_init (st) == NULL);
13238       ffecom_notify_init_storage (st);
13239     }
13240
13241 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13242   if ((ffesymbol_kind (s) == FFEINFO_kindCOMMON)
13243       && (ffesymbol_where (s) == FFEINFO_whereLOCAL)
13244       && (ffesymbol_storage (s) != NULL))
13245     {
13246       ffecom_list_common_
13247         = ffebld_new_item (ffebld_new_symter (s, FFEINTRIN_genNONE,
13248                                               FFEINTRIN_specNONE,
13249                                               FFEINTRIN_impNONE),
13250                            ffecom_list_common_);
13251     }
13252 #endif
13253
13254   return s;
13255 }
13256
13257 /* ffecom_sym_exec_transition -- Perform exec transition on all symbols
13258
13259    ffecom_sym_exec_transition();
13260
13261    Does backend-specific stuff and also calls ffest_sym_exec_transition
13262    to do the necessary FFE stuff.
13263
13264    See the long-winded description in ffecom_sym_learned for info
13265    on handling the situation where backtracking is inhibited.  */
13266
13267 ffesymbol
13268 ffecom_sym_exec_transition (ffesymbol s)
13269 {
13270   s = ffest_sym_exec_transition (s);
13271
13272   return s;
13273 }
13274
13275 /* ffecom_sym_learned -- Initial or more info gained on symbol after exec
13276
13277    ffesymbol s;
13278    s = ffecom_sym_learned(s);
13279
13280    Called when a new symbol is seen after the exec transition or when more
13281    info (perhaps) is gained for an UNCERTAIN symbol.  The symbol state when
13282    it arrives here is that all its latest info is updated already, so its
13283    state may be UNCERTAIN or UNDERSTOOD, it might already have the hook
13284    field filled in if its gone through here or exec_transition first, and
13285    so on.
13286
13287    The backend probably wants to check ffesymbol_retractable() to see if
13288    backtracking is in effect.  If so, the FFE's changes to the symbol may
13289    be retracted (undone) or committed (ratified), at which time the
13290    appropriate ffecom_sym_retract or _commit function will be called
13291    for that function.
13292
13293    If the backend has its own backtracking mechanism, great, use it so that
13294    committal is a simple operation.  Though it doesn't make much difference,
13295    I suppose: the reason for tentative symbol evolution in the FFE is to
13296    enable error detection in weird incorrect statements early and to disable
13297    incorrect error detection on a correct statement.  The backend is not
13298    likely to introduce any information that'll get involved in these
13299    considerations, so it is probably just fine that the implementation
13300    model for this fn and for _exec_transition is to not do anything
13301    (besides the required FFE stuff) if ffesymbol_retractable() returns TRUE
13302    and instead wait until ffecom_sym_commit is called (which it never
13303    will be as long as we're using ambiguity-detecting statement analysis in
13304    the FFE, which we are initially to shake out the code, but don't depend
13305    on this), otherwise go ahead and do whatever is needed.
13306
13307    In essence, then, when this fn and _exec_transition get called while
13308    backtracking is enabled, a general mechanism would be to flag which (or
13309    both) of these were called (and in what order? neat question as to what
13310    might happen that I'm too lame to think through right now) and then when
13311    _commit is called reproduce the original calling sequence, if any, for
13312    the two fns (at which point backtracking will, of course, be disabled).  */
13313
13314 ffesymbol
13315 ffecom_sym_learned (ffesymbol s)
13316 {
13317   ffestorag_exec_layout (s);
13318
13319   return s;
13320 }
13321
13322 /* ffecom_sym_retract -- Symbol's state being retracted from reality
13323
13324    ffesymbol s;
13325    ffecom_sym_retract(s);
13326
13327    Does whatever the backend needs when a symbol is retracted after having
13328    been backtrackable for a period of time.  */
13329
13330 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13331 void
13332 ffecom_sym_retract (ffesymbol s UNUSED)
13333 {
13334   assert (!ffesymbol_retractable ());
13335
13336 #if 0                           /* GCC doesn't commit any backtrackable sins,
13337                                    so nothing needed here. */
13338   switch (ffesymbol_hook (s).state)
13339     {
13340     case 0:                     /* nothing happened yet. */
13341       break;
13342
13343     case 1:                     /* exec transition happened. */
13344       break;
13345
13346     case 2:                     /* learned happened. */
13347       break;
13348
13349     case 3:                     /* learned then exec. */
13350       break;
13351
13352     case 4:                     /* exec then learned. */
13353       break;
13354
13355     default:
13356       assert ("bad hook state" == NULL);
13357       break;
13358     }
13359 #endif
13360 }
13361
13362 #endif
13363 /* Create temporary gcc label.  */
13364
13365 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13366 tree
13367 ffecom_temp_label ()
13368 {
13369   tree glabel;
13370   static int mynumber = 0;
13371
13372   glabel = build_decl (LABEL_DECL,
13373                        ffecom_get_invented_identifier ("__g77_label_%d",
13374                                                        mynumber++),
13375                        void_type_node);
13376   DECL_CONTEXT (glabel) = current_function_decl;
13377   DECL_MODE (glabel) = VOIDmode;
13378
13379   return glabel;
13380 }
13381
13382 #endif
13383 /* Return an expression that is usable as an arg in a conditional context
13384    (IF, DO WHILE, .NOT., and so on).
13385
13386    Use the one provided for the back end as of >2.6.0.  */
13387
13388 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13389 tree
13390 ffecom_truth_value (tree expr)
13391 {
13392   return truthvalue_conversion (expr);
13393 }
13394
13395 #endif
13396 /* Return the inversion of a truth value (the inversion of what
13397    ffecom_truth_value builds).
13398
13399    Apparently invert_truthvalue, which is properly in the back end, is
13400    enough for now, so just use it.  */
13401
13402 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13403 tree
13404 ffecom_truth_value_invert (tree expr)
13405 {
13406   return invert_truthvalue (ffecom_truth_value (expr));
13407 }
13408
13409 #endif
13410
13411 /* Return the tree that is the type of the expression, as would be
13412    returned in TREE_TYPE(ffecom_expr(expr)), without otherwise
13413    transforming the expression, generating temporaries, etc.  */
13414
13415 tree
13416 ffecom_type_expr (ffebld expr)
13417 {
13418   ffeinfoBasictype bt;
13419   ffeinfoKindtype kt;
13420   tree tree_type;
13421
13422   assert (expr != NULL);
13423
13424   bt = ffeinfo_basictype (ffebld_info (expr));
13425   kt = ffeinfo_kindtype (ffebld_info (expr));
13426   tree_type = ffecom_tree_type[bt][kt];
13427
13428   switch (ffebld_op (expr))
13429     {
13430     case FFEBLD_opCONTER:
13431     case FFEBLD_opSYMTER:
13432     case FFEBLD_opARRAYREF:
13433     case FFEBLD_opUPLUS:
13434     case FFEBLD_opPAREN:
13435     case FFEBLD_opUMINUS:
13436     case FFEBLD_opADD:
13437     case FFEBLD_opSUBTRACT:
13438     case FFEBLD_opMULTIPLY:
13439     case FFEBLD_opDIVIDE:
13440     case FFEBLD_opPOWER:
13441     case FFEBLD_opNOT:
13442     case FFEBLD_opFUNCREF:
13443     case FFEBLD_opSUBRREF:
13444     case FFEBLD_opAND:
13445     case FFEBLD_opOR:
13446     case FFEBLD_opXOR:
13447     case FFEBLD_opNEQV:
13448     case FFEBLD_opEQV:
13449     case FFEBLD_opCONVERT:
13450     case FFEBLD_opLT:
13451     case FFEBLD_opLE:
13452     case FFEBLD_opEQ:
13453     case FFEBLD_opNE:
13454     case FFEBLD_opGT:
13455     case FFEBLD_opGE:
13456     case FFEBLD_opPERCENT_LOC:
13457       return tree_type;
13458
13459     case FFEBLD_opACCTER:
13460     case FFEBLD_opARRTER:
13461     case FFEBLD_opITEM:
13462     case FFEBLD_opSTAR:
13463     case FFEBLD_opBOUNDS:
13464     case FFEBLD_opREPEAT:
13465     case FFEBLD_opLABTER:
13466     case FFEBLD_opLABTOK:
13467     case FFEBLD_opIMPDO:
13468     case FFEBLD_opCONCATENATE:
13469     case FFEBLD_opSUBSTR:
13470     default:
13471       assert ("bad op for ffecom_type_expr" == NULL);
13472       /* Fall through. */
13473     case FFEBLD_opANY:
13474       return error_mark_node;
13475     }
13476 }
13477
13478 /* Return PARM_DECL for arg#1 of master fn containing alternate ENTRY points
13479
13480    If the PARM_DECL already exists, return it, else create it.  It's an
13481    integer_type_node argument for the master function that implements a
13482    subroutine or function with more than one entrypoint and is bound at
13483    run time with the entrypoint number (0 for SUBROUTINE/FUNCTION, 1 for
13484    first ENTRY statement, and so on).  */
13485
13486 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13487 tree
13488 ffecom_which_entrypoint_decl ()
13489 {
13490   assert (ffecom_which_entrypoint_decl_ != NULL_TREE);
13491
13492   return ffecom_which_entrypoint_decl_;
13493 }
13494
13495 #endif
13496 \f
13497 /* The following sections consists of private and public functions
13498    that have the same names and perform roughly the same functions
13499    as counterparts in the C front end.  Changes in the C front end
13500    might affect how things should be done here.  Only functions
13501    needed by the back end should be public here; the rest should
13502    be private (static in the C sense).  Functions needed by other
13503    g77 front-end modules should be accessed by them via public
13504    ffecom_* names, which should themselves call private versions
13505    in this section so the private versions are easy to recognize
13506    when upgrading to a new gcc and finding interesting changes
13507    in the front end.
13508
13509    Functions named after rule "foo:" in c-parse.y are named
13510    "bison_rule_foo_" so they are easy to find.  */
13511
13512 #if FFECOM_targetCURRENT == FFECOM_targetGCC
13513
13514 static void
13515 bison_rule_pushlevel_ ()
13516 {
13517   emit_line_note (input_filename, lineno);
13518   pushlevel (0);
13519   clear_last_expr ();
13520   expand_start_bindings (0);
13521 }
13522
13523 static tree
13524 bison_rule_compstmt_ ()
13525 {
13526   tree t;
13527   int keep = kept_level_p ();
13528
13529   /* Make the temps go away.  */
13530   if (! keep)
13531     current_binding_level->names = NULL_TREE;
13532
13533   emit_line_note (input_filename, lineno);
13534   expand_end_bindings (getdecls (), keep, 0);
13535   t = poplevel (keep, 1, 0);
13536
13537   return t;
13538 }
13539
13540 /* Return a definition for a builtin function named NAME and whose data type
13541    is TYPE.  TYPE should be a function type with argument types.
13542    FUNCTION_CODE tells later passes how to compile calls to this function.
13543    See tree.h for its possible values.
13544
13545    If LIBRARY_NAME is nonzero, use that for DECL_ASSEMBLER_NAME,
13546    the name to be called if we can't opencode the function.  */
13547
13548 tree
13549 builtin_function (const char *name, tree type, int function_code,
13550                   enum built_in_class class,
13551                   const char *library_name)
13552 {
13553   tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
13554   DECL_EXTERNAL (decl) = 1;
13555   TREE_PUBLIC (decl) = 1;
13556   if (library_name)
13557     DECL_ASSEMBLER_NAME (decl) = get_identifier (library_name);
13558   make_decl_rtl (decl, NULL_PTR);
13559   pushdecl (decl);
13560   DECL_BUILT_IN_CLASS (decl) = class;
13561   DECL_FUNCTION_CODE (decl) = function_code;
13562
13563   return decl;
13564 }
13565
13566 /* Handle when a new declaration NEWDECL
13567    has the same name as an old one OLDDECL
13568    in the same binding contour.
13569    Prints an error message if appropriate.
13570
13571    If safely possible, alter OLDDECL to look like NEWDECL, and return 1.
13572    Otherwise, return 0.  */
13573
13574 static int
13575 duplicate_decls (tree newdecl, tree olddecl)
13576 {
13577   int types_match = 1;
13578   int new_is_definition = (TREE_CODE (newdecl) == FUNCTION_DECL
13579                            && DECL_INITIAL (newdecl) != 0);
13580   tree oldtype = TREE_TYPE (olddecl);
13581   tree newtype = TREE_TYPE (newdecl);
13582
13583   if (olddecl == newdecl)
13584     return 1;
13585
13586   if (TREE_CODE (newtype) == ERROR_MARK
13587       || TREE_CODE (oldtype) == ERROR_MARK)
13588     types_match = 0;
13589
13590   /* New decl is completely inconsistent with the old one =>
13591      tell caller to replace the old one.
13592      This is always an error except in the case of shadowing a builtin.  */
13593   if (TREE_CODE (olddecl) != TREE_CODE (newdecl))
13594     return 0;
13595
13596   /* For real parm decl following a forward decl,
13597      return 1 so old decl will be reused.  */
13598   if (types_match && TREE_CODE (newdecl) == PARM_DECL
13599       && TREE_ASM_WRITTEN (olddecl) && ! TREE_ASM_WRITTEN (newdecl))
13600     return 1;
13601
13602   /* The new declaration is the same kind of object as the old one.
13603      The declarations may partially match.  Print warnings if they don't
13604      match enough.  Ultimately, copy most of the information from the new
13605      decl to the old one, and keep using the old one.  */
13606
13607   if (TREE_CODE (olddecl) == FUNCTION_DECL
13608       && DECL_BUILT_IN (olddecl))
13609     {
13610       /* A function declaration for a built-in function.  */
13611       if (!TREE_PUBLIC (newdecl))
13612         return 0;
13613       else if (!types_match)
13614         {
13615           /* Accept the return type of the new declaration if same modes.  */
13616           tree oldreturntype = TREE_TYPE (TREE_TYPE (olddecl));
13617           tree newreturntype = TREE_TYPE (TREE_TYPE (newdecl));
13618
13619           if (TYPE_MODE (oldreturntype) == TYPE_MODE (newreturntype))
13620             {
13621               /* Function types may be shared, so we can't just modify
13622                  the return type of olddecl's function type.  */
13623               tree newtype
13624                 = build_function_type (newreturntype,
13625                                        TYPE_ARG_TYPES (TREE_TYPE (olddecl)));
13626
13627               types_match = 1;
13628               if (types_match)
13629                 TREE_TYPE (olddecl) = newtype;
13630             }
13631         }
13632       if (!types_match)
13633         return 0;
13634     }
13635   else if (TREE_CODE (olddecl) == FUNCTION_DECL
13636            && DECL_SOURCE_LINE (olddecl) == 0)
13637     {
13638       /* A function declaration for a predeclared function
13639          that isn't actually built in.  */
13640       if (!TREE_PUBLIC (newdecl))
13641         return 0;
13642       else if (!types_match)
13643         {
13644           /* If the types don't match, preserve volatility indication.
13645              Later on, we will discard everything else about the
13646              default declaration.  */
13647           TREE_THIS_VOLATILE (newdecl) |= TREE_THIS_VOLATILE (olddecl);
13648         }
13649     }
13650
13651   /* Copy all the DECL_... slots specified in the new decl
13652      except for any that we copy here from the old type.
13653
13654      Past this point, we don't change OLDTYPE and NEWTYPE
13655      even if we change the types of NEWDECL and OLDDECL.  */
13656
13657   if (types_match)
13658     {
13659       /* Merge the data types specified in the two decls.  */
13660       if (TREE_CODE (newdecl) != FUNCTION_DECL || !DECL_BUILT_IN (olddecl))
13661         TREE_TYPE (newdecl)
13662           = TREE_TYPE (olddecl)
13663             = TREE_TYPE (newdecl);
13664
13665       /* Lay the type out, unless already done.  */
13666       if (oldtype != TREE_TYPE (newdecl))
13667         {
13668           if (TREE_TYPE (newdecl) != error_mark_node)
13669             layout_type (TREE_TYPE (newdecl));
13670           if (TREE_CODE (newdecl) != FUNCTION_DECL
13671               && TREE_CODE (newdecl) != TYPE_DECL
13672               && TREE_CODE (newdecl) != CONST_DECL)
13673             layout_decl (newdecl, 0);
13674         }
13675       else
13676         {
13677           /* Since the type is OLDDECL's, make OLDDECL's size go with.  */
13678           DECL_SIZE (newdecl) = DECL_SIZE (olddecl);
13679           DECL_SIZE_UNIT (newdecl) = DECL_SIZE_UNIT (olddecl);
13680           if (TREE_CODE (olddecl) != FUNCTION_DECL)
13681             if (DECL_ALIGN (olddecl) > DECL_ALIGN (newdecl))
13682               {
13683                 DECL_ALIGN (newdecl) = DECL_ALIGN (olddecl);
13684                 DECL_USER_ALIGN (newdecl) |= DECL_USER_ALIGN (olddecl);
13685               }
13686         }
13687
13688       /* Keep the old rtl since we can safely use it.  */
13689       DECL_RTL (newdecl) = DECL_RTL (olddecl);
13690
13691       /* Merge the type qualifiers.  */
13692       if (DECL_BUILT_IN_NONANSI (olddecl) && TREE_THIS_VOLATILE (olddecl)
13693           && !TREE_THIS_VOLATILE (newdecl))
13694         TREE_THIS_VOLATILE (olddecl) = 0;
13695       if (TREE_READONLY (newdecl))
13696         TREE_READONLY (olddecl) = 1;
13697       if (TREE_THIS_VOLATILE (newdecl))
13698         {
13699           TREE_THIS_VOLATILE (olddecl) = 1;
13700           if (TREE_CODE (newdecl) == VAR_DECL)
13701             make_var_volatile (newdecl);
13702         }
13703
13704       /* Keep source location of definition rather than declaration.
13705          Likewise, keep decl at outer scope.  */
13706       if ((DECL_INITIAL (newdecl) == 0 && DECL_INITIAL (olddecl) != 0)
13707           || (DECL_CONTEXT (newdecl) != 0 && DECL_CONTEXT (olddecl) == 0))
13708         {
13709           DECL_SOURCE_LINE (newdecl) = DECL_SOURCE_LINE (olddecl);
13710           DECL_SOURCE_FILE (newdecl) = DECL_SOURCE_FILE (olddecl);
13711
13712           if (DECL_CONTEXT (olddecl) == 0
13713               && TREE_CODE (newdecl) != FUNCTION_DECL)
13714             DECL_CONTEXT (newdecl) = 0;
13715         }
13716
13717       /* Merge the unused-warning information.  */
13718       if (DECL_IN_SYSTEM_HEADER (olddecl))
13719         DECL_IN_SYSTEM_HEADER (newdecl) = 1;
13720       else if (DECL_IN_SYSTEM_HEADER (newdecl))
13721         DECL_IN_SYSTEM_HEADER (olddecl) = 1;
13722
13723       /* Merge the initialization information.  */
13724       if (DECL_INITIAL (newdecl) == 0)
13725         DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13726
13727       /* Merge the section attribute.
13728          We want to issue an error if the sections conflict but that must be
13729          done later in decl_attributes since we are called before attributes
13730          are assigned.  */
13731       if (DECL_SECTION_NAME (newdecl) == NULL_TREE)
13732         DECL_SECTION_NAME (newdecl) = DECL_SECTION_NAME (olddecl);
13733
13734 #if BUILT_FOR_270
13735       if (TREE_CODE (newdecl) == FUNCTION_DECL)
13736         {
13737           DECL_STATIC_CONSTRUCTOR(newdecl) |= DECL_STATIC_CONSTRUCTOR(olddecl);
13738           DECL_STATIC_DESTRUCTOR (newdecl) |= DECL_STATIC_DESTRUCTOR (olddecl);
13739         }
13740 #endif
13741     }
13742   /* If cannot merge, then use the new type and qualifiers,
13743      and don't preserve the old rtl.  */
13744   else
13745     {
13746       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13747       TREE_READONLY (olddecl) = TREE_READONLY (newdecl);
13748       TREE_THIS_VOLATILE (olddecl) = TREE_THIS_VOLATILE (newdecl);
13749       TREE_SIDE_EFFECTS (olddecl) = TREE_SIDE_EFFECTS (newdecl);
13750     }
13751
13752   /* Merge the storage class information.  */
13753   /* For functions, static overrides non-static.  */
13754   if (TREE_CODE (newdecl) == FUNCTION_DECL)
13755     {
13756       TREE_PUBLIC (newdecl) &= TREE_PUBLIC (olddecl);
13757       /* This is since we don't automatically
13758          copy the attributes of NEWDECL into OLDDECL.  */
13759       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13760       /* If this clears `static', clear it in the identifier too.  */
13761       if (! TREE_PUBLIC (olddecl))
13762         TREE_PUBLIC (DECL_NAME (olddecl)) = 0;
13763     }
13764   if (DECL_EXTERNAL (newdecl))
13765     {
13766       TREE_STATIC (newdecl) = TREE_STATIC (olddecl);
13767       DECL_EXTERNAL (newdecl) = DECL_EXTERNAL (olddecl);
13768       /* An extern decl does not override previous storage class.  */
13769       TREE_PUBLIC (newdecl) = TREE_PUBLIC (olddecl);
13770     }
13771   else
13772     {
13773       TREE_STATIC (olddecl) = TREE_STATIC (newdecl);
13774       TREE_PUBLIC (olddecl) = TREE_PUBLIC (newdecl);
13775     }
13776
13777   /* If either decl says `inline', this fn is inline,
13778      unless its definition was passed already.  */
13779   if (DECL_INLINE (newdecl) && DECL_INITIAL (olddecl) == 0)
13780     DECL_INLINE (olddecl) = 1;
13781   DECL_INLINE (newdecl) = DECL_INLINE (olddecl);
13782
13783   /* Get rid of any built-in function if new arg types don't match it
13784      or if we have a function definition.  */
13785   if (TREE_CODE (newdecl) == FUNCTION_DECL
13786       && DECL_BUILT_IN (olddecl)
13787       && (!types_match || new_is_definition))
13788     {
13789       TREE_TYPE (olddecl) = TREE_TYPE (newdecl);
13790       DECL_BUILT_IN_CLASS (olddecl) = NOT_BUILT_IN;
13791     }
13792
13793   /* If redeclaring a builtin function, and not a definition,
13794      it stays built in.
13795      Also preserve various other info from the definition.  */
13796   if (TREE_CODE (newdecl) == FUNCTION_DECL && !new_is_definition)
13797     {
13798       if (DECL_BUILT_IN (olddecl))
13799         {
13800           DECL_BUILT_IN_CLASS (newdecl) = DECL_BUILT_IN_CLASS (olddecl);
13801           DECL_FUNCTION_CODE (newdecl) = DECL_FUNCTION_CODE (olddecl);
13802         }
13803       else
13804         DECL_FRAME_SIZE (newdecl) = DECL_FRAME_SIZE (olddecl);
13805
13806       DECL_RESULT (newdecl) = DECL_RESULT (olddecl);
13807       DECL_INITIAL (newdecl) = DECL_INITIAL (olddecl);
13808       DECL_SAVED_INSNS (newdecl) = DECL_SAVED_INSNS (olddecl);
13809       DECL_ARGUMENTS (newdecl) = DECL_ARGUMENTS (olddecl);
13810     }
13811
13812   /* Copy most of the decl-specific fields of NEWDECL into OLDDECL.
13813      But preserve olddecl's DECL_UID.  */
13814   {
13815     register unsigned olddecl_uid = DECL_UID (olddecl);
13816
13817     memcpy ((char *) olddecl + sizeof (struct tree_common),
13818             (char *) newdecl + sizeof (struct tree_common),
13819             sizeof (struct tree_decl) - sizeof (struct tree_common));
13820     DECL_UID (olddecl) = olddecl_uid;
13821   }
13822
13823   return 1;
13824 }
13825
13826 /* Finish processing of a declaration;
13827    install its initial value.
13828    If the length of an array type is not known before,
13829    it must be determined now, from the initial value, or it is an error.  */
13830
13831 static void
13832 finish_decl (tree decl, tree init, bool is_top_level)
13833 {
13834   register tree type = TREE_TYPE (decl);
13835   int was_incomplete = (DECL_SIZE (decl) == 0);
13836   bool at_top_level = (current_binding_level == global_binding_level);
13837   bool top_level = is_top_level || at_top_level;
13838
13839   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
13840      level anyway.  */
13841   assert (!is_top_level || !at_top_level);
13842
13843   if (TREE_CODE (decl) == PARM_DECL)
13844     assert (init == NULL_TREE);
13845   /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se -- it
13846      overlaps DECL_ARG_TYPE.  */
13847   else if (init == NULL_TREE)
13848     assert (DECL_INITIAL (decl) == NULL_TREE);
13849   else
13850     assert (DECL_INITIAL (decl) == error_mark_node);
13851
13852   if (init != NULL_TREE)
13853     {
13854       if (TREE_CODE (decl) != TYPE_DECL)
13855         DECL_INITIAL (decl) = init;
13856       else
13857         {
13858           /* typedef foo = bar; store the type of bar as the type of foo.  */
13859           TREE_TYPE (decl) = TREE_TYPE (init);
13860           DECL_INITIAL (decl) = init = 0;
13861         }
13862     }
13863
13864   /* Deduce size of array from initialization, if not already known */
13865
13866   if (TREE_CODE (type) == ARRAY_TYPE
13867       && TYPE_DOMAIN (type) == 0
13868       && TREE_CODE (decl) != TYPE_DECL)
13869     {
13870       assert (top_level);
13871       assert (was_incomplete);
13872
13873       layout_decl (decl, 0);
13874     }
13875
13876   if (TREE_CODE (decl) == VAR_DECL)
13877     {
13878       if (DECL_SIZE (decl) == NULL_TREE
13879           && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
13880         layout_decl (decl, 0);
13881
13882       if (DECL_SIZE (decl) == NULL_TREE
13883           && (TREE_STATIC (decl)
13884               ?
13885       /* A static variable with an incomplete type is an error if it is
13886          initialized. Also if it is not file scope. Otherwise, let it
13887          through, but if it is not `extern' then it may cause an error
13888          message later.  */
13889               (DECL_INITIAL (decl) != 0 || DECL_CONTEXT (decl) != 0)
13890               :
13891       /* An automatic variable with an incomplete type is an error.  */
13892               !DECL_EXTERNAL (decl)))
13893         {
13894           assert ("storage size not known" == NULL);
13895           abort ();
13896         }
13897
13898       if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
13899           && (DECL_SIZE (decl) != 0)
13900           && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
13901         {
13902           assert ("storage size not constant" == NULL);
13903           abort ();
13904         }
13905     }
13906
13907   /* Output the assembler code and/or RTL code for variables and functions,
13908      unless the type is an undefined structure or union. If not, it will get
13909      done when the type is completed.  */
13910
13911   if (TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == FUNCTION_DECL)
13912     {
13913       rest_of_decl_compilation (decl, NULL,
13914                                 DECL_CONTEXT (decl) == 0,
13915                                 0);
13916
13917       if (DECL_CONTEXT (decl) != 0)
13918         {
13919           /* Recompute the RTL of a local array now if it used to be an
13920              incomplete type.  */
13921           if (was_incomplete
13922               && !TREE_STATIC (decl) && !DECL_EXTERNAL (decl))
13923             {
13924               /* If we used it already as memory, it must stay in memory.  */
13925               TREE_ADDRESSABLE (decl) = TREE_USED (decl);
13926               /* If it's still incomplete now, no init will save it.  */
13927               if (DECL_SIZE (decl) == 0)
13928                 DECL_INITIAL (decl) = 0;
13929               expand_decl (decl);
13930             }
13931           /* Compute and store the initial value.  */
13932           if (TREE_CODE (decl) != FUNCTION_DECL)
13933             expand_decl_init (decl);
13934         }
13935     }
13936   else if (TREE_CODE (decl) == TYPE_DECL)
13937     {
13938       rest_of_decl_compilation (decl, NULL_PTR,
13939                                 DECL_CONTEXT (decl) == 0,
13940                                 0);
13941     }
13942
13943   /* At the end of a declaration, throw away any variable type sizes of types
13944      defined inside that declaration.  There is no use computing them in the
13945      following function definition.  */
13946   if (current_binding_level == global_binding_level)
13947     get_pending_sizes ();
13948 }
13949
13950 /* Finish up a function declaration and compile that function
13951    all the way to assembler language output.  The free the storage
13952    for the function definition.
13953
13954    This is called after parsing the body of the function definition.
13955
13956    NESTED is nonzero if the function being finished is nested in another.  */
13957
13958 static void
13959 finish_function (int nested)
13960 {
13961   register tree fndecl = current_function_decl;
13962
13963   assert (fndecl != NULL_TREE);
13964   if (TREE_CODE (fndecl) != ERROR_MARK)
13965     {
13966       if (nested)
13967         assert (DECL_CONTEXT (fndecl) != NULL_TREE);
13968       else
13969         assert (DECL_CONTEXT (fndecl) == NULL_TREE);
13970     }
13971
13972 /*  TREE_READONLY (fndecl) = 1;
13973     This caused &foo to be of type ptr-to-const-function
13974     which then got a warning when stored in a ptr-to-function variable.  */
13975
13976   poplevel (1, 0, 1);
13977
13978   if (TREE_CODE (fndecl) != ERROR_MARK)
13979     {
13980       BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
13981
13982       /* Must mark the RESULT_DECL as being in this function.  */
13983
13984       DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
13985
13986       /* Obey `register' declarations if `setjmp' is called in this fn.  */
13987       /* Generate rtl for function exit.  */
13988       expand_function_end (input_filename, lineno, 0);
13989
13990       /* If this is a nested function, protect the local variables in the stack
13991          above us from being collected while we're compiling this function.  */
13992       if (nested)
13993         ggc_push_context ();
13994
13995       /* Run the optimizers and output the assembler code for this function.  */
13996       rest_of_compilation (fndecl);
13997
13998       /* Undo the GC context switch.  */
13999       if (nested)
14000         ggc_pop_context ();
14001     }
14002
14003   if (TREE_CODE (fndecl) != ERROR_MARK
14004       && !nested
14005       && DECL_SAVED_INSNS (fndecl) == 0)
14006     {
14007       /* Stop pointing to the local nodes about to be freed.  */
14008       /* But DECL_INITIAL must remain nonzero so we know this was an actual
14009          function definition.  */
14010       /* For a nested function, this is done in pop_f_function_context.  */
14011       /* If rest_of_compilation set this to 0, leave it 0.  */
14012       if (DECL_INITIAL (fndecl) != 0)
14013         DECL_INITIAL (fndecl) = error_mark_node;
14014       DECL_ARGUMENTS (fndecl) = 0;
14015     }
14016
14017   if (!nested)
14018     {
14019       /* Let the error reporting routines know that we're outside a function.
14020          For a nested function, this value is used in pop_c_function_context
14021          and then reset via pop_function_context.  */
14022       ffecom_outer_function_decl_ = current_function_decl = NULL;
14023     }
14024 }
14025
14026 /* Plug-in replacement for identifying the name of a decl and, for a
14027    function, what we call it in diagnostics.  For now, "program unit"
14028    should suffice, since it's a bit of a hassle to figure out which
14029    of several kinds of things it is.  Note that it could conceivably
14030    be a statement function, which probably isn't really a program unit
14031    per se, but if that comes up, it should be easy to check (being a
14032    nested function and all).  */
14033
14034 static const char *
14035 lang_printable_name (tree decl, int v)
14036 {
14037   /* Just to keep GCC quiet about the unused variable.
14038      In theory, differing values of V should produce different
14039      output.  */
14040   switch (v)
14041     {
14042     default:
14043       if (TREE_CODE (decl) == ERROR_MARK)
14044         return "erroneous code";
14045       return IDENTIFIER_POINTER (DECL_NAME (decl));
14046     }
14047 }
14048
14049 /* g77's function to print out name of current function that caused
14050    an error.  */
14051
14052 #if BUILT_FOR_270
14053 static void
14054 lang_print_error_function (const char *file)
14055 {
14056   static ffeglobal last_g = NULL;
14057   static ffesymbol last_s = NULL;
14058   ffeglobal g;
14059   ffesymbol s;
14060   const char *kind;
14061
14062   if ((ffecom_primary_entry_ == NULL)
14063       || (ffesymbol_global (ffecom_primary_entry_) == NULL))
14064     {
14065       g = NULL;
14066       s = NULL;
14067       kind = NULL;
14068     }
14069   else
14070     {
14071       g = ffesymbol_global (ffecom_primary_entry_);
14072       if (ffecom_nested_entry_ == NULL)
14073         {
14074           s = ffecom_primary_entry_;
14075           switch (ffesymbol_kind (s))
14076             {
14077             case FFEINFO_kindFUNCTION:
14078               kind = "function";
14079               break;
14080
14081             case FFEINFO_kindSUBROUTINE:
14082               kind = "subroutine";
14083               break;
14084
14085             case FFEINFO_kindPROGRAM:
14086               kind = "program";
14087               break;
14088
14089             case FFEINFO_kindBLOCKDATA:
14090               kind = "block-data";
14091               break;
14092
14093             default:
14094               kind = ffeinfo_kind_message (ffesymbol_kind (s));
14095               break;
14096             }
14097         }
14098       else
14099         {
14100           s = ffecom_nested_entry_;
14101           kind = "statement function";
14102         }
14103     }
14104
14105   if ((last_g != g) || (last_s != s))
14106     {
14107       if (file)
14108         fprintf (stderr, "%s: ", file);
14109
14110       if (s == NULL)
14111         fprintf (stderr, "Outside of any program unit:\n");
14112       else
14113         {
14114           const char *name = ffesymbol_text (s);
14115
14116           fprintf (stderr, "In %s `%s':\n", kind, name);
14117         }
14118
14119       last_g = g;
14120       last_s = s;
14121     }
14122 }
14123 #endif
14124
14125 /* Similar to `lookup_name' but look only at current binding level.  */
14126
14127 static tree
14128 lookup_name_current_level (tree name)
14129 {
14130   register tree t;
14131
14132   if (current_binding_level == global_binding_level)
14133     return IDENTIFIER_GLOBAL_VALUE (name);
14134
14135   if (IDENTIFIER_LOCAL_VALUE (name) == 0)
14136     return 0;
14137
14138   for (t = current_binding_level->names; t; t = TREE_CHAIN (t))
14139     if (DECL_NAME (t) == name)
14140       break;
14141
14142   return t;
14143 }
14144
14145 /* Create a new `struct binding_level'.  */
14146
14147 static struct binding_level *
14148 make_binding_level ()
14149 {
14150   /* NOSTRICT */
14151   return (struct binding_level *) xmalloc (sizeof (struct binding_level));
14152 }
14153
14154 /* Save and restore the variables in this file and elsewhere
14155    that keep track of the progress of compilation of the current function.
14156    Used for nested functions.  */
14157
14158 struct f_function
14159 {
14160   struct f_function *next;
14161   tree named_labels;
14162   tree shadowed_labels;
14163   struct binding_level *binding_level;
14164 };
14165
14166 struct f_function *f_function_chain;
14167
14168 /* Restore the variables used during compilation of a C function.  */
14169
14170 static void
14171 pop_f_function_context ()
14172 {
14173   struct f_function *p = f_function_chain;
14174   tree link;
14175
14176   /* Bring back all the labels that were shadowed.  */
14177   for (link = shadowed_labels; link; link = TREE_CHAIN (link))
14178     if (DECL_NAME (TREE_VALUE (link)) != 0)
14179       IDENTIFIER_LABEL_VALUE (DECL_NAME (TREE_VALUE (link)))
14180         = TREE_VALUE (link);
14181
14182   if (current_function_decl != error_mark_node
14183       && DECL_SAVED_INSNS (current_function_decl) == 0)
14184     {
14185       /* Stop pointing to the local nodes about to be freed.  */
14186       /* But DECL_INITIAL must remain nonzero so we know this was an actual
14187          function definition.  */
14188       DECL_INITIAL (current_function_decl) = error_mark_node;
14189       DECL_ARGUMENTS (current_function_decl) = 0;
14190     }
14191
14192   pop_function_context ();
14193
14194   f_function_chain = p->next;
14195
14196   named_labels = p->named_labels;
14197   shadowed_labels = p->shadowed_labels;
14198   current_binding_level = p->binding_level;
14199
14200   free (p);
14201 }
14202
14203 /* Save and reinitialize the variables
14204    used during compilation of a C function.  */
14205
14206 static void
14207 push_f_function_context ()
14208 {
14209   struct f_function *p
14210   = (struct f_function *) xmalloc (sizeof (struct f_function));
14211
14212   push_function_context ();
14213
14214   p->next = f_function_chain;
14215   f_function_chain = p;
14216
14217   p->named_labels = named_labels;
14218   p->shadowed_labels = shadowed_labels;
14219   p->binding_level = current_binding_level;
14220 }
14221
14222 static void
14223 push_parm_decl (tree parm)
14224 {
14225   int old_immediate_size_expand = immediate_size_expand;
14226
14227   /* Don't try computing parm sizes now -- wait till fn is called.  */
14228
14229   immediate_size_expand = 0;
14230
14231   /* Fill in arg stuff.  */
14232
14233   DECL_ARG_TYPE (parm) = TREE_TYPE (parm);
14234   DECL_ARG_TYPE_AS_WRITTEN (parm) = TREE_TYPE (parm);
14235   TREE_READONLY (parm) = 1;     /* All implementation args are read-only. */
14236
14237   parm = pushdecl (parm);
14238
14239   immediate_size_expand = old_immediate_size_expand;
14240
14241   finish_decl (parm, NULL_TREE, FALSE);
14242 }
14243
14244 /* Like pushdecl, only it places X in GLOBAL_BINDING_LEVEL, if appropriate.  */
14245
14246 static tree
14247 pushdecl_top_level (x)
14248      tree x;
14249 {
14250   register tree t;
14251   register struct binding_level *b = current_binding_level;
14252   register tree f = current_function_decl;
14253
14254   current_binding_level = global_binding_level;
14255   current_function_decl = NULL_TREE;
14256   t = pushdecl (x);
14257   current_binding_level = b;
14258   current_function_decl = f;
14259   return t;
14260 }
14261
14262 /* Store the list of declarations of the current level.
14263    This is done for the parameter declarations of a function being defined,
14264    after they are modified in the light of any missing parameters.  */
14265
14266 static tree
14267 storedecls (decls)
14268      tree decls;
14269 {
14270   return current_binding_level->names = decls;
14271 }
14272
14273 /* Store the parameter declarations into the current function declaration.
14274    This is called after parsing the parameter declarations, before
14275    digesting the body of the function.
14276
14277    For an old-style definition, modify the function's type
14278    to specify at least the number of arguments.  */
14279
14280 static void
14281 store_parm_decls (int is_main_program UNUSED)
14282 {
14283   register tree fndecl = current_function_decl;
14284
14285   if (fndecl == error_mark_node)
14286     return;
14287
14288   /* This is a chain of PARM_DECLs from old-style parm declarations.  */
14289   DECL_ARGUMENTS (fndecl) = storedecls (nreverse (getdecls ()));
14290
14291   /* Initialize the RTL code for the function.  */
14292
14293   init_function_start (fndecl, input_filename, lineno);
14294
14295   /* Set up parameters and prepare for return, for the function.  */
14296
14297   expand_function_start (fndecl, 0);
14298 }
14299
14300 static tree
14301 start_decl (tree decl, bool is_top_level)
14302 {
14303   register tree tem;
14304   bool at_top_level = (current_binding_level == global_binding_level);
14305   bool top_level = is_top_level || at_top_level;
14306
14307   /* Caller should pass TRUE for is_top_level only if we wouldn't be at top
14308      level anyway.  */
14309   assert (!is_top_level || !at_top_level);
14310
14311   if (DECL_INITIAL (decl) != NULL_TREE)
14312     {
14313       assert (DECL_INITIAL (decl) == error_mark_node);
14314       assert (!DECL_EXTERNAL (decl));
14315     }
14316   else if (top_level)
14317     assert ((TREE_STATIC (decl) == 1) || DECL_EXTERNAL (decl) == 1);
14318
14319   /* For Fortran, we by default put things in .common when possible.  */
14320   DECL_COMMON (decl) = 1;
14321
14322   /* Add this decl to the current binding level. TEM may equal DECL or it may
14323      be a previous decl of the same name.  */
14324   if (is_top_level)
14325     tem = pushdecl_top_level (decl);
14326   else
14327     tem = pushdecl (decl);
14328
14329   /* For a local variable, define the RTL now.  */
14330   if (!top_level
14331   /* But not if this is a duplicate decl and we preserved the rtl from the
14332      previous one (which may or may not happen).  */
14333       && DECL_RTL (tem) == 0)
14334     {
14335       if (TYPE_SIZE (TREE_TYPE (tem)) != 0)
14336         expand_decl (tem);
14337       else if (TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE
14338                && DECL_INITIAL (tem) != 0)
14339         expand_decl (tem);
14340     }
14341
14342   return tem;
14343 }
14344
14345 /* Create the FUNCTION_DECL for a function definition.
14346    DECLSPECS and DECLARATOR are the parts of the declaration;
14347    they describe the function's name and the type it returns,
14348    but twisted together in a fashion that parallels the syntax of C.
14349
14350    This function creates a binding context for the function body
14351    as well as setting up the FUNCTION_DECL in current_function_decl.
14352
14353    Returns 1 on success.  If the DECLARATOR is not suitable for a function
14354    (it defines a datum instead), we return 0, which tells
14355    yyparse to report a parse error.
14356
14357    NESTED is nonzero for a function nested within another function.  */
14358
14359 static void
14360 start_function (tree name, tree type, int nested, int public)
14361 {
14362   tree decl1;
14363   tree restype;
14364   int old_immediate_size_expand = immediate_size_expand;
14365
14366   named_labels = 0;
14367   shadowed_labels = 0;
14368
14369   /* Don't expand any sizes in the return type of the function.  */
14370   immediate_size_expand = 0;
14371
14372   if (nested)
14373     {
14374       assert (!public);
14375       assert (current_function_decl != NULL_TREE);
14376       assert (DECL_CONTEXT (current_function_decl) == NULL_TREE);
14377     }
14378   else
14379     {
14380       assert (current_function_decl == NULL_TREE);
14381     }
14382
14383   if (TREE_CODE (type) == ERROR_MARK)
14384     decl1 = current_function_decl = error_mark_node;
14385   else
14386     {
14387       decl1 = build_decl (FUNCTION_DECL,
14388                           name,
14389                           type);
14390       TREE_PUBLIC (decl1) = public ? 1 : 0;
14391       if (nested)
14392         DECL_INLINE (decl1) = 1;
14393       TREE_STATIC (decl1) = 1;
14394       DECL_EXTERNAL (decl1) = 0;
14395
14396       announce_function (decl1);
14397
14398       /* Make the init_value nonzero so pushdecl knows this is not tentative.
14399          error_mark_node is replaced below (in poplevel) with the BLOCK.  */
14400       DECL_INITIAL (decl1) = error_mark_node;
14401
14402       /* Record the decl so that the function name is defined. If we already have
14403          a decl for this name, and it is a FUNCTION_DECL, use the old decl.  */
14404
14405       current_function_decl = pushdecl (decl1);
14406     }
14407
14408   if (!nested)
14409     ffecom_outer_function_decl_ = current_function_decl;
14410
14411   pushlevel (0);
14412   current_binding_level->prep_state = 2;
14413
14414   if (TREE_CODE (current_function_decl) != ERROR_MARK)
14415     {
14416       make_decl_rtl (current_function_decl, NULL);
14417
14418       restype = TREE_TYPE (TREE_TYPE (current_function_decl));
14419       DECL_RESULT (current_function_decl)
14420         = build_decl (RESULT_DECL, NULL_TREE, restype);
14421     }
14422
14423   if (!nested && (TREE_CODE (current_function_decl) != ERROR_MARK))
14424     TREE_ADDRESSABLE (current_function_decl) = 1;
14425
14426   immediate_size_expand = old_immediate_size_expand;
14427 }
14428 \f
14429 /* Here are the public functions the GNU back end needs.  */
14430
14431 tree
14432 convert (type, expr)
14433      tree type, expr;
14434 {
14435   register tree e = expr;
14436   register enum tree_code code = TREE_CODE (type);
14437
14438   if (type == TREE_TYPE (e)
14439       || TREE_CODE (e) == ERROR_MARK)
14440     return e;
14441   if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (e)))
14442     return fold (build1 (NOP_EXPR, type, e));
14443   if (TREE_CODE (TREE_TYPE (e)) == ERROR_MARK
14444       || code == ERROR_MARK)
14445     return error_mark_node;
14446   if (TREE_CODE (TREE_TYPE (e)) == VOID_TYPE)
14447     {
14448       assert ("void value not ignored as it ought to be" == NULL);
14449       return error_mark_node;
14450     }
14451   if (code == VOID_TYPE)
14452     return build1 (CONVERT_EXPR, type, e);
14453   if ((code != RECORD_TYPE)
14454       && (TREE_CODE (TREE_TYPE (e)) == RECORD_TYPE))
14455     e = ffecom_1 (REALPART_EXPR, TREE_TYPE (TYPE_FIELDS (TREE_TYPE (e))),
14456                   e);
14457   if (code == INTEGER_TYPE || code == ENUMERAL_TYPE)
14458     return fold (convert_to_integer (type, e));
14459   if (code == POINTER_TYPE)
14460     return fold (convert_to_pointer (type, e));
14461   if (code == REAL_TYPE)
14462     return fold (convert_to_real (type, e));
14463   if (code == COMPLEX_TYPE)
14464     return fold (convert_to_complex (type, e));
14465   if (code == RECORD_TYPE)
14466     return fold (ffecom_convert_to_complex_ (type, e));
14467
14468   assert ("conversion to non-scalar type requested" == NULL);
14469   return error_mark_node;
14470 }
14471
14472 /* integrate_decl_tree calls this function, but since we don't use the
14473    DECL_LANG_SPECIFIC field, this is a no-op.  */
14474
14475 void
14476 copy_lang_decl (node)
14477      tree node UNUSED;
14478 {
14479 }
14480
14481 /* Return the list of declarations of the current level.
14482    Note that this list is in reverse order unless/until
14483    you nreverse it; and when you do nreverse it, you must
14484    store the result back using `storedecls' or you will lose.  */
14485
14486 tree
14487 getdecls ()
14488 {
14489   return current_binding_level->names;
14490 }
14491
14492 /* Nonzero if we are currently in the global binding level.  */
14493
14494 int
14495 global_bindings_p ()
14496 {
14497   return current_binding_level == global_binding_level;
14498 }
14499
14500 /* Print an error message for invalid use of an incomplete type.
14501    VALUE is the expression that was used (or 0 if that isn't known)
14502    and TYPE is the type that was invalid.  */
14503
14504 void
14505 incomplete_type_error (value, type)
14506      tree value UNUSED;
14507      tree type;
14508 {
14509   if (TREE_CODE (type) == ERROR_MARK)
14510     return;
14511
14512   assert ("incomplete type?!?" == NULL);
14513 }
14514
14515 /* Mark ARG for GC.  */
14516 static void
14517 mark_binding_level (void *arg)
14518 {
14519   struct binding_level *level = *(struct binding_level **) arg;
14520
14521   while (level)
14522     {
14523       ggc_mark_tree (level->names);
14524       ggc_mark_tree (level->blocks);
14525       ggc_mark_tree (level->this_block);
14526       level = level->level_chain;
14527     }
14528 }
14529
14530 void
14531 init_decl_processing ()
14532 {
14533   static tree *const tree_roots[] = {
14534     &current_function_decl,
14535     &string_type_node,
14536     &ffecom_tree_fun_type_void,
14537     &ffecom_integer_zero_node,
14538     &ffecom_integer_one_node,
14539     &ffecom_tree_subr_type,
14540     &ffecom_tree_ptr_to_subr_type,
14541     &ffecom_tree_blockdata_type,
14542     &ffecom_tree_xargc_,
14543     &ffecom_f2c_integer_type_node,
14544     &ffecom_f2c_ptr_to_integer_type_node,
14545     &ffecom_f2c_address_type_node,
14546     &ffecom_f2c_real_type_node,
14547     &ffecom_f2c_ptr_to_real_type_node,
14548     &ffecom_f2c_doublereal_type_node,
14549     &ffecom_f2c_complex_type_node,
14550     &ffecom_f2c_doublecomplex_type_node,
14551     &ffecom_f2c_longint_type_node,
14552     &ffecom_f2c_logical_type_node,
14553     &ffecom_f2c_flag_type_node,
14554     &ffecom_f2c_ftnlen_type_node,
14555     &ffecom_f2c_ftnlen_zero_node,
14556     &ffecom_f2c_ftnlen_one_node,
14557     &ffecom_f2c_ftnlen_two_node,
14558     &ffecom_f2c_ptr_to_ftnlen_type_node,
14559     &ffecom_f2c_ftnint_type_node,
14560     &ffecom_f2c_ptr_to_ftnint_type_node,
14561     &ffecom_outer_function_decl_,
14562     &ffecom_previous_function_decl_,
14563     &ffecom_which_entrypoint_decl_,
14564     &ffecom_float_zero_,
14565     &ffecom_float_half_,
14566     &ffecom_double_zero_,
14567     &ffecom_double_half_,
14568     &ffecom_func_result_,
14569     &ffecom_func_length_,
14570     &ffecom_multi_type_node_,
14571     &ffecom_multi_retval_,
14572     &named_labels,
14573     &shadowed_labels
14574   };
14575   size_t i;
14576
14577   malloc_init ();
14578
14579   /* Record our roots.  */
14580   for (i = 0; i < ARRAY_SIZE (tree_roots); i++)
14581     ggc_add_tree_root (tree_roots[i], 1);
14582   ggc_add_tree_root (&ffecom_tree_type[0][0],
14583                      FFEINFO_basictype*FFEINFO_kindtype);
14584   ggc_add_tree_root (&ffecom_tree_fun_type[0][0],
14585                      FFEINFO_basictype*FFEINFO_kindtype);
14586   ggc_add_tree_root (&ffecom_tree_ptr_to_fun_type[0][0],
14587                      FFEINFO_basictype*FFEINFO_kindtype);
14588   ggc_add_tree_root (ffecom_gfrt_, FFECOM_gfrt);
14589   ggc_add_root (&current_binding_level, 1, sizeof current_binding_level,
14590                 mark_binding_level);
14591   ggc_add_root (&free_binding_level, 1, sizeof current_binding_level,
14592                 mark_binding_level);
14593   ggc_add_root (&tracker_head, 1, sizeof tracker_head, mark_tracker_head);
14594
14595   ffe_init_0 ();
14596 }
14597
14598 const char *
14599 init_parse (filename)
14600      const char *filename;
14601 {
14602   /* Open input file.  */
14603   if (filename == 0 || !strcmp (filename, "-"))
14604     {
14605       finput = stdin;
14606       filename = "stdin";
14607     }
14608   else
14609     finput = fopen (filename, "r");
14610   if (finput == 0)
14611     fatal_io_error ("can't open %s", filename);
14612
14613 #ifdef IO_BUFFER_SIZE
14614   setvbuf (finput, (char *) xmalloc (IO_BUFFER_SIZE), _IOFBF, IO_BUFFER_SIZE);
14615 #endif
14616
14617   /* Make identifier nodes long enough for the language-specific slots.  */
14618   set_identifier_size (sizeof (struct lang_identifier));
14619   decl_printable_name = lang_printable_name;
14620 #if BUILT_FOR_270
14621   print_error_function = lang_print_error_function;
14622 #endif
14623
14624   return filename;
14625 }
14626
14627 void
14628 finish_parse ()
14629 {
14630   fclose (finput);
14631 }
14632
14633 /* Delete the node BLOCK from the current binding level.
14634    This is used for the block inside a stmt expr ({...})
14635    so that the block can be reinserted where appropriate.  */
14636
14637 static void
14638 delete_block (block)
14639      tree block;
14640 {
14641   tree t;
14642   if (current_binding_level->blocks == block)
14643     current_binding_level->blocks = TREE_CHAIN (block);
14644   for (t = current_binding_level->blocks; t;)
14645     {
14646       if (TREE_CHAIN (t) == block)
14647         TREE_CHAIN (t) = TREE_CHAIN (block);
14648       else
14649         t = TREE_CHAIN (t);
14650     }
14651   TREE_CHAIN (block) = NULL;
14652   /* Clear TREE_USED which is always set by poplevel.
14653      The flag is set again if insert_block is called.  */
14654   TREE_USED (block) = 0;
14655 }
14656
14657 void
14658 insert_block (block)
14659      tree block;
14660 {
14661   TREE_USED (block) = 1;
14662   current_binding_level->blocks
14663     = chainon (current_binding_level->blocks, block);
14664 }
14665
14666 /* Each front end provides its own.  */
14667 static void ffe_init PARAMS ((void));
14668 static void ffe_finish PARAMS ((void));
14669 static void ffe_init_options PARAMS ((void));
14670
14671 struct lang_hooks lang_hooks = {ffe_init,
14672                                 ffe_finish,
14673                                 ffe_init_options,
14674                                 ffe_decode_option,
14675                                 NULL /* post_options */};
14676
14677 /* used by print-tree.c */
14678
14679 void
14680 lang_print_xnode (file, node, indent)
14681      FILE *file UNUSED;
14682      tree node UNUSED;
14683      int indent UNUSED;
14684 {
14685 }
14686
14687 static void
14688 ffe_finish ()
14689 {
14690   ffe_terminate_0 ();
14691
14692   if (ffe_is_ffedebug ())
14693     malloc_pool_display (malloc_pool_image ());
14694 }
14695
14696 const char *
14697 lang_identify ()
14698 {
14699   return "f77";
14700 }
14701
14702 /* Return the typed-based alias set for T, which may be an expression
14703    or a type.  Return -1 if we don't do anything special.  */
14704
14705 HOST_WIDE_INT
14706 lang_get_alias_set (t)
14707      tree t ATTRIBUTE_UNUSED;
14708 {
14709   /* We do not wish to use alias-set based aliasing at all.  Used in the
14710      extreme (every object with its own set, with equivalences recorded)
14711      it might be helpful, but there are problems when it comes to inlining.
14712      We get on ok with flag_argument_noalias, and alias-set aliasing does
14713      currently limit how stack slots can be reused, which is a lose.  */
14714   return 0;
14715 }
14716
14717 static void
14718 ffe_init_options ()
14719 {
14720   /* Set default options for Fortran.  */
14721   flag_move_all_movables = 1;
14722   flag_reduce_all_givs = 1;
14723   flag_argument_noalias = 2;
14724   flag_errno_math = 0;
14725   flag_complex_divide_method = 1;
14726 }
14727
14728 static void
14729 ffe_init ()
14730 {
14731   /* If the file is output from cpp, it should contain a first line
14732      `# 1 "real-filename"', and the current design of gcc (toplev.c
14733      in particular and the way it sets up information relied on by
14734      INCLUDE) requires that we read this now, and store the
14735      "real-filename" info in master_input_filename.  Ask the lexer
14736      to try doing this.  */
14737   ffelex_hash_kludge (finput);
14738 }
14739
14740 int
14741 mark_addressable (exp)
14742      tree exp;
14743 {
14744   register tree x = exp;
14745   while (1)
14746     switch (TREE_CODE (x))
14747       {
14748       case ADDR_EXPR:
14749       case COMPONENT_REF:
14750       case ARRAY_REF:
14751         x = TREE_OPERAND (x, 0);
14752         break;
14753
14754       case CONSTRUCTOR:
14755         TREE_ADDRESSABLE (x) = 1;
14756         return 1;
14757
14758       case VAR_DECL:
14759       case CONST_DECL:
14760       case PARM_DECL:
14761       case RESULT_DECL:
14762         if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x)
14763             && DECL_NONLOCAL (x))
14764           {
14765             if (TREE_PUBLIC (x))
14766               {
14767                 assert ("address of global register var requested" == NULL);
14768                 return 0;
14769               }
14770             assert ("address of register variable requested" == NULL);
14771           }
14772         else if (DECL_REGISTER (x) && !TREE_ADDRESSABLE (x))
14773           {
14774             if (TREE_PUBLIC (x))
14775               {
14776                 assert ("address of global register var requested" == NULL);
14777                 return 0;
14778               }
14779             assert ("address of register var requested" == NULL);
14780           }
14781         put_var_into_stack (x);
14782
14783         /* drops in */
14784       case FUNCTION_DECL:
14785         TREE_ADDRESSABLE (x) = 1;
14786 #if 0                           /* poplevel deals with this now.  */
14787         if (DECL_CONTEXT (x) == 0)
14788           TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (x)) = 1;
14789 #endif
14790
14791       default:
14792         return 1;
14793       }
14794 }
14795
14796 /* If DECL has a cleanup, build and return that cleanup here.
14797    This is a callback called by expand_expr.  */
14798
14799 tree
14800 maybe_build_cleanup (decl)
14801      tree decl UNUSED;
14802 {
14803   /* There are no cleanups in Fortran.  */
14804   return NULL_TREE;
14805 }
14806
14807 /* Exit a binding level.
14808    Pop the level off, and restore the state of the identifier-decl mappings
14809    that were in effect when this level was entered.
14810
14811    If KEEP is nonzero, this level had explicit declarations, so
14812    and create a "block" (a BLOCK node) for the level
14813    to record its declarations and subblocks for symbol table output.
14814
14815    If FUNCTIONBODY is nonzero, this level is the body of a function,
14816    so create a block as if KEEP were set and also clear out all
14817    label names.
14818
14819    If REVERSE is nonzero, reverse the order of decls before putting
14820    them into the BLOCK.  */
14821
14822 tree
14823 poplevel (keep, reverse, functionbody)
14824      int keep;
14825      int reverse;
14826      int functionbody;
14827 {
14828   register tree link;
14829   /* The chain of decls was accumulated in reverse order.
14830      Put it into forward order, just for cleanliness.  */
14831   tree decls;
14832   tree subblocks = current_binding_level->blocks;
14833   tree block = 0;
14834   tree decl;
14835   int block_previously_created;
14836
14837   /* Get the decls in the order they were written.
14838      Usually current_binding_level->names is in reverse order.
14839      But parameter decls were previously put in forward order.  */
14840
14841   if (reverse)
14842     current_binding_level->names
14843       = decls = nreverse (current_binding_level->names);
14844   else
14845     decls = current_binding_level->names;
14846
14847   /* Output any nested inline functions within this block
14848      if they weren't already output.  */
14849
14850   for (decl = decls; decl; decl = TREE_CHAIN (decl))
14851     if (TREE_CODE (decl) == FUNCTION_DECL
14852         && ! TREE_ASM_WRITTEN (decl)
14853         && DECL_INITIAL (decl) != 0
14854         && TREE_ADDRESSABLE (decl))
14855       {
14856         /* If this decl was copied from a file-scope decl
14857            on account of a block-scope extern decl,
14858            propagate TREE_ADDRESSABLE to the file-scope decl.
14859
14860            DECL_ABSTRACT_ORIGIN can be set to itself if warn_return_type is
14861            true, since then the decl goes through save_for_inline_copying.  */
14862         if (DECL_ABSTRACT_ORIGIN (decl) != 0
14863             && DECL_ABSTRACT_ORIGIN (decl) != decl)
14864           TREE_ADDRESSABLE (DECL_ABSTRACT_ORIGIN (decl)) = 1;
14865         else if (DECL_SAVED_INSNS (decl) != 0)
14866           {
14867             push_function_context ();
14868             output_inline_function (decl);
14869             pop_function_context ();
14870           }
14871       }
14872
14873   /* If there were any declarations or structure tags in that level,
14874      or if this level is a function body,
14875      create a BLOCK to record them for the life of this function.  */
14876
14877   block = 0;
14878   block_previously_created = (current_binding_level->this_block != 0);
14879   if (block_previously_created)
14880     block = current_binding_level->this_block;
14881   else if (keep || functionbody)
14882     block = make_node (BLOCK);
14883   if (block != 0)
14884     {
14885       BLOCK_VARS (block) = decls;
14886       BLOCK_SUBBLOCKS (block) = subblocks;
14887     }
14888
14889   /* In each subblock, record that this is its superior.  */
14890
14891   for (link = subblocks; link; link = TREE_CHAIN (link))
14892     BLOCK_SUPERCONTEXT (link) = block;
14893
14894   /* Clear out the meanings of the local variables of this level.  */
14895
14896   for (link = decls; link; link = TREE_CHAIN (link))
14897     {
14898       if (DECL_NAME (link) != 0)
14899         {
14900           /* If the ident. was used or addressed via a local extern decl,
14901              don't forget that fact.  */
14902           if (DECL_EXTERNAL (link))
14903             {
14904               if (TREE_USED (link))
14905                 TREE_USED (DECL_NAME (link)) = 1;
14906               if (TREE_ADDRESSABLE (link))
14907                 TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (link)) = 1;
14908             }
14909           IDENTIFIER_LOCAL_VALUE (DECL_NAME (link)) = 0;
14910         }
14911     }
14912
14913   /* If the level being exited is the top level of a function,
14914      check over all the labels, and clear out the current
14915      (function local) meanings of their names.  */
14916
14917   if (functionbody)
14918     {
14919       /* If this is the top level block of a function,
14920          the vars are the function's parameters.
14921          Don't leave them in the BLOCK because they are
14922          found in the FUNCTION_DECL instead.  */
14923
14924       BLOCK_VARS (block) = 0;
14925     }
14926
14927   /* Pop the current level, and free the structure for reuse.  */
14928
14929   {
14930     register struct binding_level *level = current_binding_level;
14931     current_binding_level = current_binding_level->level_chain;
14932
14933     level->level_chain = free_binding_level;
14934     free_binding_level = level;
14935   }
14936
14937   /* Dispose of the block that we just made inside some higher level.  */
14938   if (functionbody
14939       && current_function_decl != error_mark_node)
14940     DECL_INITIAL (current_function_decl) = block;
14941   else if (block)
14942     {
14943       if (!block_previously_created)
14944         current_binding_level->blocks
14945           = chainon (current_binding_level->blocks, block);
14946     }
14947   /* If we did not make a block for the level just exited,
14948      any blocks made for inner levels
14949      (since they cannot be recorded as subblocks in that level)
14950      must be carried forward so they will later become subblocks
14951      of something else.  */
14952   else if (subblocks)
14953     current_binding_level->blocks
14954       = chainon (current_binding_level->blocks, subblocks);
14955
14956   if (block)
14957     TREE_USED (block) = 1;
14958   return block;
14959 }
14960
14961 void
14962 print_lang_decl (file, node, indent)
14963      FILE *file UNUSED;
14964      tree node UNUSED;
14965      int indent UNUSED;
14966 {
14967 }
14968
14969 void
14970 print_lang_identifier (file, node, indent)
14971      FILE *file;
14972      tree node;
14973      int indent;
14974 {
14975   print_node (file, "global", IDENTIFIER_GLOBAL_VALUE (node), indent + 4);
14976   print_node (file, "local", IDENTIFIER_LOCAL_VALUE (node), indent + 4);
14977 }
14978
14979 void
14980 print_lang_statistics ()
14981 {
14982 }
14983
14984 void
14985 print_lang_type (file, node, indent)
14986      FILE *file UNUSED;
14987      tree node UNUSED;
14988      int indent UNUSED;
14989 {
14990 }
14991
14992 /* Record a decl-node X as belonging to the current lexical scope.
14993    Check for errors (such as an incompatible declaration for the same
14994    name already seen in the same scope).
14995
14996    Returns either X or an old decl for the same name.
14997    If an old decl is returned, it may have been smashed
14998    to agree with what X says.  */
14999
15000 tree
15001 pushdecl (x)
15002      tree x;
15003 {
15004   register tree t;
15005   register tree name = DECL_NAME (x);
15006   register struct binding_level *b = current_binding_level;
15007
15008   if ((TREE_CODE (x) == FUNCTION_DECL)
15009       && (DECL_INITIAL (x) == 0)
15010       && DECL_EXTERNAL (x))
15011     DECL_CONTEXT (x) = NULL_TREE;
15012   else
15013     DECL_CONTEXT (x) = current_function_decl;
15014
15015   if (name)
15016     {
15017       if (IDENTIFIER_INVENTED (name))
15018         {
15019 #if BUILT_FOR_270
15020           DECL_ARTIFICIAL (x) = 1;
15021 #endif
15022           DECL_IN_SYSTEM_HEADER (x) = 1;
15023         }
15024
15025       t = lookup_name_current_level (name);
15026
15027       assert ((t == NULL_TREE) || (DECL_CONTEXT (x) == NULL_TREE));
15028
15029       /* Don't push non-parms onto list for parms until we understand
15030          why we're doing this and whether it works.  */
15031
15032       assert ((b == global_binding_level)
15033               || !ffecom_transform_only_dummies_
15034               || TREE_CODE (x) == PARM_DECL);
15035
15036       if ((t != NULL_TREE) && duplicate_decls (x, t))
15037         return t;
15038
15039       /* If we are processing a typedef statement, generate a whole new
15040          ..._TYPE node (which will be just an variant of the existing
15041          ..._TYPE node with identical properties) and then install the
15042          TYPE_DECL node generated to represent the typedef name as the
15043          TYPE_NAME of this brand new (duplicate) ..._TYPE node.
15044
15045          The whole point here is to end up with a situation where each and every
15046          ..._TYPE node the compiler creates will be uniquely associated with
15047          AT MOST one node representing a typedef name. This way, even though
15048          the compiler substitutes corresponding ..._TYPE nodes for TYPE_DECL
15049          (i.e. "typedef name") nodes very early on, later parts of the
15050          compiler can always do the reverse translation and get back the
15051          corresponding typedef name.  For example, given:
15052
15053          typedef struct S MY_TYPE; MY_TYPE object;
15054
15055          Later parts of the compiler might only know that `object' was of type
15056          `struct S' if it were not for code just below.  With this code
15057          however, later parts of the compiler see something like:
15058
15059          struct S' == struct S typedef struct S' MY_TYPE; struct S' object;
15060
15061          And they can then deduce (from the node for type struct S') that the
15062          original object declaration was:
15063
15064          MY_TYPE object;
15065
15066          Being able to do this is important for proper support of protoize, and
15067          also for generating precise symbolic debugging information which
15068          takes full account of the programmer's (typedef) vocabulary.
15069
15070          Obviously, we don't want to generate a duplicate ..._TYPE node if the
15071          TYPE_DECL node that we are now processing really represents a
15072          standard built-in type.
15073
15074          Since all standard types are effectively declared at line zero in the
15075          source file, we can easily check to see if we are working on a
15076          standard type by checking the current value of lineno.  */
15077
15078       if (TREE_CODE (x) == TYPE_DECL)
15079         {
15080           if (DECL_SOURCE_LINE (x) == 0)
15081             {
15082               if (TYPE_NAME (TREE_TYPE (x)) == 0)
15083                 TYPE_NAME (TREE_TYPE (x)) = x;
15084             }
15085           else if (TREE_TYPE (x) != error_mark_node)
15086             {
15087               tree tt = TREE_TYPE (x);
15088
15089               tt = build_type_copy (tt);
15090               TYPE_NAME (tt) = x;
15091               TREE_TYPE (x) = tt;
15092             }
15093         }
15094
15095       /* This name is new in its binding level. Install the new declaration
15096          and return it.  */
15097       if (b == global_binding_level)
15098         IDENTIFIER_GLOBAL_VALUE (name) = x;
15099       else
15100         IDENTIFIER_LOCAL_VALUE (name) = x;
15101     }
15102
15103   /* Put decls on list in reverse order. We will reverse them later if
15104      necessary.  */
15105   TREE_CHAIN (x) = b->names;
15106   b->names = x;
15107
15108   return x;
15109 }
15110
15111 /* Nonzero if the current level needs to have a BLOCK made.  */
15112
15113 static int
15114 kept_level_p ()
15115 {
15116   tree decl;
15117
15118   for (decl = current_binding_level->names;
15119        decl;
15120        decl = TREE_CHAIN (decl))
15121     {
15122       if (TREE_USED (decl) || TREE_CODE (decl) != VAR_DECL
15123           || (DECL_NAME (decl) && ! DECL_ARTIFICIAL (decl)))
15124         /* Currently, there aren't supposed to be non-artificial names
15125            at other than the top block for a function -- they're
15126            believed to always be temps.  But it's wise to check anyway.  */
15127         return 1;
15128     }
15129   return 0;
15130 }
15131
15132 /* Enter a new binding level.
15133    If TAG_TRANSPARENT is nonzero, do so only for the name space of variables,
15134    not for that of tags.  */
15135
15136 void
15137 pushlevel (tag_transparent)
15138      int tag_transparent;
15139 {
15140   register struct binding_level *newlevel = NULL_BINDING_LEVEL;
15141
15142   assert (! tag_transparent);
15143
15144   if (current_binding_level == global_binding_level)
15145     {
15146       named_labels = 0;
15147     }
15148
15149   /* Reuse or create a struct for this binding level.  */
15150
15151   if (free_binding_level)
15152     {
15153       newlevel = free_binding_level;
15154       free_binding_level = free_binding_level->level_chain;
15155     }
15156   else
15157     {
15158       newlevel = make_binding_level ();
15159     }
15160
15161   /* Add this level to the front of the chain (stack) of levels that
15162      are active.  */
15163
15164   *newlevel = clear_binding_level;
15165   newlevel->level_chain = current_binding_level;
15166   current_binding_level = newlevel;
15167 }
15168
15169 /* Set the BLOCK node for the innermost scope
15170    (the one we are currently in).  */
15171
15172 void
15173 set_block (block)
15174      register tree block;
15175 {
15176   current_binding_level->this_block = block;
15177 }
15178
15179 /* ~~gcc/tree.h *should* declare this, because toplev.c references it.  */
15180
15181 /* Can't 'yydebug' a front end not generated by yacc/bison!  */
15182
15183 void
15184 set_yydebug (value)
15185      int value;
15186 {
15187   if (value)
15188     fprintf (stderr, "warning: no yacc/bison-generated output to debug!\n");
15189 }
15190
15191 tree
15192 signed_or_unsigned_type (unsignedp, type)
15193      int unsignedp;
15194      tree type;
15195 {
15196   tree type2;
15197
15198   if (! INTEGRAL_TYPE_P (type))
15199     return type;
15200   if (TYPE_PRECISION (type) == TYPE_PRECISION (signed_char_type_node))
15201     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15202   if (TYPE_PRECISION (type) == TYPE_PRECISION (integer_type_node))
15203     return unsignedp ? unsigned_type_node : integer_type_node;
15204   if (TYPE_PRECISION (type) == TYPE_PRECISION (short_integer_type_node))
15205     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15206   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_integer_type_node))
15207     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15208   if (TYPE_PRECISION (type) == TYPE_PRECISION (long_long_integer_type_node))
15209     return (unsignedp ? long_long_unsigned_type_node
15210             : long_long_integer_type_node);
15211
15212   type2 = type_for_size (TYPE_PRECISION (type), unsignedp);
15213   if (type2 == NULL_TREE)
15214     return type;
15215
15216   return type2;
15217 }
15218
15219 tree
15220 signed_type (type)
15221      tree type;
15222 {
15223   tree type1 = TYPE_MAIN_VARIANT (type);
15224   ffeinfoKindtype kt;
15225   tree type2;
15226
15227   if (type1 == unsigned_char_type_node || type1 == char_type_node)
15228     return signed_char_type_node;
15229   if (type1 == unsigned_type_node)
15230     return integer_type_node;
15231   if (type1 == short_unsigned_type_node)
15232     return short_integer_type_node;
15233   if (type1 == long_unsigned_type_node)
15234     return long_integer_type_node;
15235   if (type1 == long_long_unsigned_type_node)
15236     return long_long_integer_type_node;
15237 #if 0   /* gcc/c-* files only */
15238   if (type1 == unsigned_intDI_type_node)
15239     return intDI_type_node;
15240   if (type1 == unsigned_intSI_type_node)
15241     return intSI_type_node;
15242   if (type1 == unsigned_intHI_type_node)
15243     return intHI_type_node;
15244   if (type1 == unsigned_intQI_type_node)
15245     return intQI_type_node;
15246 #endif
15247
15248   type2 = type_for_size (TYPE_PRECISION (type1), 0);
15249   if (type2 != NULL_TREE)
15250     return type2;
15251
15252   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15253     {
15254       type2 = ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15255
15256       if (type1 == type2)
15257         return ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15258     }
15259
15260   return type;
15261 }
15262
15263 /* Prepare expr to be an argument of a TRUTH_NOT_EXPR,
15264    or validate its data type for an `if' or `while' statement or ?..: exp.
15265
15266    This preparation consists of taking the ordinary
15267    representation of an expression expr and producing a valid tree
15268    boolean expression describing whether expr is nonzero.  We could
15269    simply always do build_binary_op (NE_EXPR, expr, integer_zero_node, 1),
15270    but we optimize comparisons, &&, ||, and !.
15271
15272    The resulting type should always be `integer_type_node'.  */
15273
15274 tree
15275 truthvalue_conversion (expr)
15276      tree expr;
15277 {
15278   if (TREE_CODE (expr) == ERROR_MARK)
15279     return expr;
15280
15281 #if 0 /* This appears to be wrong for C++.  */
15282   /* These really should return error_mark_node after 2.4 is stable.
15283      But not all callers handle ERROR_MARK properly.  */
15284   switch (TREE_CODE (TREE_TYPE (expr)))
15285     {
15286     case RECORD_TYPE:
15287       error ("struct type value used where scalar is required");
15288       return integer_zero_node;
15289
15290     case UNION_TYPE:
15291       error ("union type value used where scalar is required");
15292       return integer_zero_node;
15293
15294     case ARRAY_TYPE:
15295       error ("array type value used where scalar is required");
15296       return integer_zero_node;
15297
15298     default:
15299       break;
15300     }
15301 #endif /* 0 */
15302
15303   switch (TREE_CODE (expr))
15304     {
15305       /* It is simpler and generates better code to have only TRUTH_*_EXPR
15306          or comparison expressions as truth values at this level.  */
15307 #if 0
15308     case COMPONENT_REF:
15309       /* A one-bit unsigned bit-field is already acceptable.  */
15310       if (1 == TREE_INT_CST_LOW (DECL_SIZE (TREE_OPERAND (expr, 1)))
15311           && TREE_UNSIGNED (TREE_OPERAND (expr, 1)))
15312         return expr;
15313       break;
15314 #endif
15315
15316     case EQ_EXPR:
15317       /* It is simpler and generates better code to have only TRUTH_*_EXPR
15318          or comparison expressions as truth values at this level.  */
15319 #if 0
15320       if (integer_zerop (TREE_OPERAND (expr, 1)))
15321         return build_unary_op (TRUTH_NOT_EXPR, TREE_OPERAND (expr, 0), 0);
15322 #endif
15323     case NE_EXPR: case LE_EXPR: case GE_EXPR: case LT_EXPR: case GT_EXPR:
15324     case TRUTH_ANDIF_EXPR:
15325     case TRUTH_ORIF_EXPR:
15326     case TRUTH_AND_EXPR:
15327     case TRUTH_OR_EXPR:
15328     case TRUTH_XOR_EXPR:
15329       TREE_TYPE (expr) = integer_type_node;
15330       return expr;
15331
15332     case ERROR_MARK:
15333       return expr;
15334
15335     case INTEGER_CST:
15336       return integer_zerop (expr) ? integer_zero_node : integer_one_node;
15337
15338     case REAL_CST:
15339       return real_zerop (expr) ? integer_zero_node : integer_one_node;
15340
15341     case ADDR_EXPR:
15342       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 0)))
15343         return build (COMPOUND_EXPR, integer_type_node,
15344                       TREE_OPERAND (expr, 0), integer_one_node);
15345       else
15346         return integer_one_node;
15347
15348     case COMPLEX_EXPR:
15349       return ffecom_2 ((TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1))
15350                         ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
15351                        integer_type_node,
15352                        truthvalue_conversion (TREE_OPERAND (expr, 0)),
15353                        truthvalue_conversion (TREE_OPERAND (expr, 1)));
15354
15355     case NEGATE_EXPR:
15356     case ABS_EXPR:
15357     case FLOAT_EXPR:
15358     case FFS_EXPR:
15359       /* These don't change whether an object is non-zero or zero.  */
15360       return truthvalue_conversion (TREE_OPERAND (expr, 0));
15361
15362     case LROTATE_EXPR:
15363     case RROTATE_EXPR:
15364       /* These don't change whether an object is zero or non-zero, but
15365          we can't ignore them if their second arg has side-effects.  */
15366       if (TREE_SIDE_EFFECTS (TREE_OPERAND (expr, 1)))
15367         return build (COMPOUND_EXPR, integer_type_node, TREE_OPERAND (expr, 1),
15368                       truthvalue_conversion (TREE_OPERAND (expr, 0)));
15369       else
15370         return truthvalue_conversion (TREE_OPERAND (expr, 0));
15371
15372     case COND_EXPR:
15373       /* Distribute the conversion into the arms of a COND_EXPR.  */
15374       return fold (build (COND_EXPR, integer_type_node, TREE_OPERAND (expr, 0),
15375                           truthvalue_conversion (TREE_OPERAND (expr, 1)),
15376                           truthvalue_conversion (TREE_OPERAND (expr, 2))));
15377
15378     case CONVERT_EXPR:
15379       /* Don't cancel the effect of a CONVERT_EXPR from a REFERENCE_TYPE,
15380          since that affects how `default_conversion' will behave.  */
15381       if (TREE_CODE (TREE_TYPE (expr)) == REFERENCE_TYPE
15382           || TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == REFERENCE_TYPE)
15383         break;
15384       /* fall through... */
15385     case NOP_EXPR:
15386       /* If this is widening the argument, we can ignore it.  */
15387       if (TYPE_PRECISION (TREE_TYPE (expr))
15388           >= TYPE_PRECISION (TREE_TYPE (TREE_OPERAND (expr, 0))))
15389         return truthvalue_conversion (TREE_OPERAND (expr, 0));
15390       break;
15391
15392     case MINUS_EXPR:
15393       /* With IEEE arithmetic, x - x may not equal 0, so we can't optimize
15394          this case.  */
15395       if (TARGET_FLOAT_FORMAT == IEEE_FLOAT_FORMAT
15396           && TREE_CODE (TREE_TYPE (expr)) == REAL_TYPE)
15397         break;
15398       /* fall through... */
15399     case BIT_XOR_EXPR:
15400       /* This and MINUS_EXPR can be changed into a comparison of the
15401          two objects.  */
15402       if (TREE_TYPE (TREE_OPERAND (expr, 0))
15403           == TREE_TYPE (TREE_OPERAND (expr, 1)))
15404         return ffecom_2 (NE_EXPR, integer_type_node,
15405                          TREE_OPERAND (expr, 0),
15406                          TREE_OPERAND (expr, 1));
15407       return ffecom_2 (NE_EXPR, integer_type_node,
15408                        TREE_OPERAND (expr, 0),
15409                        fold (build1 (NOP_EXPR,
15410                                      TREE_TYPE (TREE_OPERAND (expr, 0)),
15411                                      TREE_OPERAND (expr, 1))));
15412
15413     case BIT_AND_EXPR:
15414       if (integer_onep (TREE_OPERAND (expr, 1)))
15415         return expr;
15416       break;
15417
15418     case MODIFY_EXPR:
15419 #if 0                           /* No such thing in Fortran. */
15420       if (warn_parentheses && C_EXP_ORIGINAL_CODE (expr) == MODIFY_EXPR)
15421         warning ("suggest parentheses around assignment used as truth value");
15422 #endif
15423       break;
15424
15425     default:
15426       break;
15427     }
15428
15429   if (TREE_CODE (TREE_TYPE (expr)) == COMPLEX_TYPE)
15430     return (ffecom_2
15431             ((TREE_SIDE_EFFECTS (expr)
15432               ? TRUTH_OR_EXPR : TRUTH_ORIF_EXPR),
15433              integer_type_node,
15434              truthvalue_conversion (ffecom_1 (REALPART_EXPR,
15435                                               TREE_TYPE (TREE_TYPE (expr)),
15436                                               expr)),
15437              truthvalue_conversion (ffecom_1 (IMAGPART_EXPR,
15438                                               TREE_TYPE (TREE_TYPE (expr)),
15439                                               expr))));
15440
15441   return ffecom_2 (NE_EXPR, integer_type_node,
15442                    expr,
15443                    convert (TREE_TYPE (expr), integer_zero_node));
15444 }
15445
15446 tree
15447 type_for_mode (mode, unsignedp)
15448      enum machine_mode mode;
15449      int unsignedp;
15450 {
15451   int i;
15452   int j;
15453   tree t;
15454
15455   if (mode == TYPE_MODE (integer_type_node))
15456     return unsignedp ? unsigned_type_node : integer_type_node;
15457
15458   if (mode == TYPE_MODE (signed_char_type_node))
15459     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15460
15461   if (mode == TYPE_MODE (short_integer_type_node))
15462     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15463
15464   if (mode == TYPE_MODE (long_integer_type_node))
15465     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15466
15467   if (mode == TYPE_MODE (long_long_integer_type_node))
15468     return unsignedp ? long_long_unsigned_type_node : long_long_integer_type_node;
15469
15470 #if HOST_BITS_PER_WIDE_INT >= 64
15471   if (mode == TYPE_MODE (intTI_type_node))
15472     return unsignedp ? unsigned_intTI_type_node : intTI_type_node;
15473 #endif
15474
15475   if (mode == TYPE_MODE (float_type_node))
15476     return float_type_node;
15477
15478   if (mode == TYPE_MODE (double_type_node))
15479     return double_type_node;
15480
15481   if (mode == TYPE_MODE (build_pointer_type (char_type_node)))
15482     return build_pointer_type (char_type_node);
15483
15484   if (mode == TYPE_MODE (build_pointer_type (integer_type_node)))
15485     return build_pointer_type (integer_type_node);
15486
15487   for (i = 0; ((size_t) i) < ARRAY_SIZE (ffecom_tree_type); ++i)
15488     for (j = 0; ((size_t) j) < ARRAY_SIZE (ffecom_tree_type[0]); ++j)
15489       {
15490         if (((t = ffecom_tree_type[i][j]) != NULL_TREE)
15491             && (mode == TYPE_MODE (t)))
15492           {
15493             if ((i == FFEINFO_basictypeINTEGER) && unsignedp)
15494               return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][j];
15495             else
15496               return t;
15497           }
15498       }
15499
15500   return 0;
15501 }
15502
15503 tree
15504 type_for_size (bits, unsignedp)
15505      unsigned bits;
15506      int unsignedp;
15507 {
15508   ffeinfoKindtype kt;
15509   tree type_node;
15510
15511   if (bits == TYPE_PRECISION (integer_type_node))
15512     return unsignedp ? unsigned_type_node : integer_type_node;
15513
15514   if (bits == TYPE_PRECISION (signed_char_type_node))
15515     return unsignedp ? unsigned_char_type_node : signed_char_type_node;
15516
15517   if (bits == TYPE_PRECISION (short_integer_type_node))
15518     return unsignedp ? short_unsigned_type_node : short_integer_type_node;
15519
15520   if (bits == TYPE_PRECISION (long_integer_type_node))
15521     return unsignedp ? long_unsigned_type_node : long_integer_type_node;
15522
15523   if (bits == TYPE_PRECISION (long_long_integer_type_node))
15524     return (unsignedp ? long_long_unsigned_type_node
15525             : long_long_integer_type_node);
15526
15527   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15528     {
15529       type_node = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15530
15531       if ((type_node != NULL_TREE) && (bits == TYPE_PRECISION (type_node)))
15532         return unsignedp ? ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt]
15533           : type_node;
15534     }
15535
15536   return 0;
15537 }
15538
15539 tree
15540 unsigned_type (type)
15541      tree type;
15542 {
15543   tree type1 = TYPE_MAIN_VARIANT (type);
15544   ffeinfoKindtype kt;
15545   tree type2;
15546
15547   if (type1 == signed_char_type_node || type1 == char_type_node)
15548     return unsigned_char_type_node;
15549   if (type1 == integer_type_node)
15550     return unsigned_type_node;
15551   if (type1 == short_integer_type_node)
15552     return short_unsigned_type_node;
15553   if (type1 == long_integer_type_node)
15554     return long_unsigned_type_node;
15555   if (type1 == long_long_integer_type_node)
15556     return long_long_unsigned_type_node;
15557 #if 0   /* gcc/c-* files only */
15558   if (type1 == intDI_type_node)
15559     return unsigned_intDI_type_node;
15560   if (type1 == intSI_type_node)
15561     return unsigned_intSI_type_node;
15562   if (type1 == intHI_type_node)
15563     return unsigned_intHI_type_node;
15564   if (type1 == intQI_type_node)
15565     return unsigned_intQI_type_node;
15566 #endif
15567
15568   type2 = type_for_size (TYPE_PRECISION (type1), 1);
15569   if (type2 != NULL_TREE)
15570     return type2;
15571
15572   for (kt = 0; kt < ARRAY_SIZE (ffecom_tree_type[0]); ++kt)
15573     {
15574       type2 = ffecom_tree_type[FFEINFO_basictypeINTEGER][kt];
15575
15576       if (type1 == type2)
15577         return ffecom_tree_type[FFEINFO_basictypeHOLLERITH][kt];
15578     }
15579
15580   return type;
15581 }
15582
15583 void
15584 lang_mark_tree (t)
15585      union tree_node *t ATTRIBUTE_UNUSED;
15586 {
15587   if (TREE_CODE (t) == IDENTIFIER_NODE)
15588     {
15589       struct lang_identifier *i = (struct lang_identifier *) t;
15590       ggc_mark_tree (IDENTIFIER_GLOBAL_VALUE (i));
15591       ggc_mark_tree (IDENTIFIER_LOCAL_VALUE (i));
15592       ggc_mark_tree (IDENTIFIER_LABEL_VALUE (i));
15593     }
15594   else if (TYPE_P (t) && TYPE_LANG_SPECIFIC (t))
15595     ggc_mark (TYPE_LANG_SPECIFIC (t));
15596 }
15597
15598 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
15599 \f
15600 #if FFECOM_GCC_INCLUDE
15601
15602 /* From gcc/cccp.c, the code to handle -I.  */
15603
15604 /* Skip leading "./" from a directory name.
15605    This may yield the empty string, which represents the current directory.  */
15606
15607 static const char *
15608 skip_redundant_dir_prefix (const char *dir)
15609 {
15610   while (dir[0] == '.' && dir[1] == '/')
15611     for (dir += 2; *dir == '/'; dir++)
15612       continue;
15613   if (dir[0] == '.' && !dir[1])
15614     dir++;
15615   return dir;
15616 }
15617
15618 /* The file_name_map structure holds a mapping of file names for a
15619    particular directory.  This mapping is read from the file named
15620    FILE_NAME_MAP_FILE in that directory.  Such a file can be used to
15621    map filenames on a file system with severe filename restrictions,
15622    such as DOS.  The format of the file name map file is just a series
15623    of lines with two tokens on each line.  The first token is the name
15624    to map, and the second token is the actual name to use.  */
15625
15626 struct file_name_map
15627 {
15628   struct file_name_map *map_next;
15629   char *map_from;
15630   char *map_to;
15631 };
15632
15633 #define FILE_NAME_MAP_FILE "header.gcc"
15634
15635 /* Current maximum length of directory names in the search path
15636    for include files.  (Altered as we get more of them.)  */
15637
15638 static int max_include_len = 0;
15639
15640 struct file_name_list
15641   {
15642     struct file_name_list *next;
15643     char *fname;
15644     /* Mapping of file names for this directory.  */
15645     struct file_name_map *name_map;
15646     /* Non-zero if name_map is valid.  */
15647     int got_name_map;
15648   };
15649
15650 static struct file_name_list *include = NULL;   /* First dir to search */
15651 static struct file_name_list *last_include = NULL;      /* Last in chain */
15652
15653 /* I/O buffer structure.
15654    The `fname' field is nonzero for source files and #include files
15655    and for the dummy text used for -D and -U.
15656    It is zero for rescanning results of macro expansion
15657    and for expanding macro arguments.  */
15658 #define INPUT_STACK_MAX 400
15659 static struct file_buf {
15660   const char *fname;
15661   /* Filename specified with #line command.  */
15662   const char *nominal_fname;
15663   /* Record where in the search path this file was found.
15664      For #include_next.  */
15665   struct file_name_list *dir;
15666   ffewhereLine line;
15667   ffewhereColumn column;
15668 } instack[INPUT_STACK_MAX];
15669
15670 static int last_error_tick = 0;    /* Incremented each time we print it.  */
15671 static int input_file_stack_tick = 0;  /* Incremented when status changes.  */
15672
15673 /* Current nesting level of input sources.
15674    `instack[indepth]' is the level currently being read.  */
15675 static int indepth = -1;
15676
15677 typedef struct file_buf FILE_BUF;
15678
15679 typedef unsigned char U_CHAR;
15680
15681 /* table to tell if char can be part of a C identifier. */
15682 U_CHAR is_idchar[256];
15683 /* table to tell if char can be first char of a c identifier. */
15684 U_CHAR is_idstart[256];
15685 /* table to tell if c is horizontal space.  */
15686 U_CHAR is_hor_space[256];
15687 /* table to tell if c is horizontal or vertical space.  */
15688 static U_CHAR is_space[256];
15689
15690 #define SKIP_WHITE_SPACE(p) do { while (is_hor_space[*p]) p++; } while (0)
15691 #define SKIP_ALL_WHITE_SPACE(p) do { while (is_space[*p]) p++; } while (0)
15692
15693 /* Nonzero means -I- has been seen,
15694    so don't look for #include "foo" the source-file directory.  */
15695 static int ignore_srcdir;
15696
15697 #ifndef INCLUDE_LEN_FUDGE
15698 #define INCLUDE_LEN_FUDGE 0
15699 #endif
15700
15701 static void append_include_chain (struct file_name_list *first,
15702                                   struct file_name_list *last);
15703 static FILE *open_include_file (char *filename,
15704                                 struct file_name_list *searchptr);
15705 static void print_containing_files (ffebadSeverity sev);
15706 static const char *skip_redundant_dir_prefix (const char *);
15707 static char *read_filename_string (int ch, FILE *f);
15708 static struct file_name_map *read_name_map (const char *dirname);
15709
15710 /* Append a chain of `struct file_name_list's
15711    to the end of the main include chain.
15712    FIRST is the beginning of the chain to append, and LAST is the end.  */
15713
15714 static void
15715 append_include_chain (first, last)
15716      struct file_name_list *first, *last;
15717 {
15718   struct file_name_list *dir;
15719
15720   if (!first || !last)
15721     return;
15722
15723   if (include == 0)
15724     include = first;
15725   else
15726     last_include->next = first;
15727
15728   for (dir = first; ; dir = dir->next) {
15729     int len = strlen (dir->fname) + INCLUDE_LEN_FUDGE;
15730     if (len > max_include_len)
15731       max_include_len = len;
15732     if (dir == last)
15733       break;
15734   }
15735
15736   last->next = NULL;
15737   last_include = last;
15738 }
15739
15740 /* Try to open include file FILENAME.  SEARCHPTR is the directory
15741    being tried from the include file search path.  This function maps
15742    filenames on file systems based on information read by
15743    read_name_map.  */
15744
15745 static FILE *
15746 open_include_file (filename, searchptr)
15747      char *filename;
15748      struct file_name_list *searchptr;
15749 {
15750   register struct file_name_map *map;
15751   register char *from;
15752   char *p, *dir;
15753
15754   if (searchptr && ! searchptr->got_name_map)
15755     {
15756       searchptr->name_map = read_name_map (searchptr->fname
15757                                            ? searchptr->fname : ".");
15758       searchptr->got_name_map = 1;
15759     }
15760
15761   /* First check the mapping for the directory we are using.  */
15762   if (searchptr && searchptr->name_map)
15763     {
15764       from = filename;
15765       if (searchptr->fname)
15766         from += strlen (searchptr->fname) + 1;
15767       for (map = searchptr->name_map; map; map = map->map_next)
15768         {
15769           if (! strcmp (map->map_from, from))
15770             {
15771               /* Found a match.  */
15772               return fopen (map->map_to, "r");
15773             }
15774         }
15775     }
15776
15777   /* Try to find a mapping file for the particular directory we are
15778      looking in.  Thus #include <sys/types.h> will look up sys/types.h
15779      in /usr/include/header.gcc and look up types.h in
15780      /usr/include/sys/header.gcc.  */
15781   p = strrchr (filename, '/');
15782 #ifdef DIR_SEPARATOR
15783   if (! p) p = strrchr (filename, DIR_SEPARATOR);
15784   else {
15785     char *tmp = strrchr (filename, DIR_SEPARATOR);
15786     if (tmp != NULL && tmp > p) p = tmp;
15787   }
15788 #endif
15789   if (! p)
15790     p = filename;
15791   if (searchptr
15792       && searchptr->fname
15793       && strlen (searchptr->fname) == (size_t) (p - filename)
15794       && ! strncmp (searchptr->fname, filename, (int) (p - filename)))
15795     {
15796       /* FILENAME is in SEARCHPTR, which we've already checked.  */
15797       return fopen (filename, "r");
15798     }
15799
15800   if (p == filename)
15801     {
15802       from = filename;
15803       map = read_name_map (".");
15804     }
15805   else
15806     {
15807       dir = (char *) xmalloc (p - filename + 1);
15808       memcpy (dir, filename, p - filename);
15809       dir[p - filename] = '\0';
15810       from = p + 1;
15811       map = read_name_map (dir);
15812       free (dir);
15813     }
15814   for (; map; map = map->map_next)
15815     if (! strcmp (map->map_from, from))
15816       return fopen (map->map_to, "r");
15817
15818   return fopen (filename, "r");
15819 }
15820
15821 /* Print the file names and line numbers of the #include
15822    commands which led to the current file.  */
15823
15824 static void
15825 print_containing_files (ffebadSeverity sev)
15826 {
15827   FILE_BUF *ip = NULL;
15828   int i;
15829   int first = 1;
15830   const char *str1;
15831   const char *str2;
15832
15833   /* If stack of files hasn't changed since we last printed
15834      this info, don't repeat it.  */
15835   if (last_error_tick == input_file_stack_tick)
15836     return;
15837
15838   for (i = indepth; i >= 0; i--)
15839     if (instack[i].fname != NULL) {
15840       ip = &instack[i];
15841       break;
15842     }
15843
15844   /* Give up if we don't find a source file.  */
15845   if (ip == NULL)
15846     return;
15847
15848   /* Find the other, outer source files.  */
15849   for (i--; i >= 0; i--)
15850     if (instack[i].fname != NULL)
15851       {
15852         ip = &instack[i];
15853         if (first)
15854           {
15855             first = 0;
15856             str1 = "In file included";
15857           }
15858         else
15859           {
15860             str1 = "...          ...";
15861           }
15862
15863         if (i == 1)
15864           str2 = ":";
15865         else
15866           str2 = "";
15867
15868         ffebad_start_msg ("%A from %B at %0%C", sev);
15869         ffebad_here (0, ip->line, ip->column);
15870         ffebad_string (str1);
15871         ffebad_string (ip->nominal_fname);
15872         ffebad_string (str2);
15873         ffebad_finish ();
15874       }
15875
15876   /* Record we have printed the status as of this time.  */
15877   last_error_tick = input_file_stack_tick;
15878 }
15879
15880 /* Read a space delimited string of unlimited length from a stdio
15881    file.  */
15882
15883 static char *
15884 read_filename_string (ch, f)
15885      int ch;
15886      FILE *f;
15887 {
15888   char *alloc, *set;
15889   int len;
15890
15891   len = 20;
15892   set = alloc = xmalloc (len + 1);
15893   if (! is_space[ch])
15894     {
15895       *set++ = ch;
15896       while ((ch = getc (f)) != EOF && ! is_space[ch])
15897         {
15898           if (set - alloc == len)
15899             {
15900               len *= 2;
15901               alloc = xrealloc (alloc, len + 1);
15902               set = alloc + len / 2;
15903             }
15904           *set++ = ch;
15905         }
15906     }
15907   *set = '\0';
15908   ungetc (ch, f);
15909   return alloc;
15910 }
15911
15912 /* Read the file name map file for DIRNAME.  */
15913
15914 static struct file_name_map *
15915 read_name_map (dirname)
15916      const char *dirname;
15917 {
15918   /* This structure holds a linked list of file name maps, one per
15919      directory.  */
15920   struct file_name_map_list
15921     {
15922       struct file_name_map_list *map_list_next;
15923       char *map_list_name;
15924       struct file_name_map *map_list_map;
15925     };
15926   static struct file_name_map_list *map_list;
15927   register struct file_name_map_list *map_list_ptr;
15928   char *name;
15929   FILE *f;
15930   size_t dirlen;
15931   int separator_needed;
15932
15933   dirname = skip_redundant_dir_prefix (dirname);
15934
15935   for (map_list_ptr = map_list; map_list_ptr;
15936        map_list_ptr = map_list_ptr->map_list_next)
15937     if (! strcmp (map_list_ptr->map_list_name, dirname))
15938       return map_list_ptr->map_list_map;
15939
15940   map_list_ptr = ((struct file_name_map_list *)
15941                   xmalloc (sizeof (struct file_name_map_list)));
15942   map_list_ptr->map_list_name = xstrdup (dirname);
15943   map_list_ptr->map_list_map = NULL;
15944
15945   dirlen = strlen (dirname);
15946   separator_needed = dirlen != 0 && dirname[dirlen - 1] != '/';
15947   name = (char *) xmalloc (dirlen + strlen (FILE_NAME_MAP_FILE) + 2);
15948   strcpy (name, dirname);
15949   name[dirlen] = '/';
15950   strcpy (name + dirlen + separator_needed, FILE_NAME_MAP_FILE);
15951   f = fopen (name, "r");
15952   free (name);
15953   if (!f)
15954     map_list_ptr->map_list_map = NULL;
15955   else
15956     {
15957       int ch;
15958
15959       while ((ch = getc (f)) != EOF)
15960         {
15961           char *from, *to;
15962           struct file_name_map *ptr;
15963
15964           if (is_space[ch])
15965             continue;
15966           from = read_filename_string (ch, f);
15967           while ((ch = getc (f)) != EOF && is_hor_space[ch])
15968             ;
15969           to = read_filename_string (ch, f);
15970
15971           ptr = ((struct file_name_map *)
15972                  xmalloc (sizeof (struct file_name_map)));
15973           ptr->map_from = from;
15974
15975           /* Make the real filename absolute.  */
15976           if (*to == '/')
15977             ptr->map_to = to;
15978           else
15979             {
15980               ptr->map_to = xmalloc (dirlen + strlen (to) + 2);
15981               strcpy (ptr->map_to, dirname);
15982               ptr->map_to[dirlen] = '/';
15983               strcpy (ptr->map_to + dirlen + separator_needed, to);
15984               free (to);
15985             }
15986
15987           ptr->map_next = map_list_ptr->map_list_map;
15988           map_list_ptr->map_list_map = ptr;
15989
15990           while ((ch = getc (f)) != '\n')
15991             if (ch == EOF)
15992               break;
15993         }
15994       fclose (f);
15995     }
15996
15997   map_list_ptr->map_list_next = map_list;
15998   map_list = map_list_ptr;
15999
16000   return map_list_ptr->map_list_map;
16001 }
16002
16003 static void
16004 ffecom_file_ (const char *name)
16005 {
16006   FILE_BUF *fp;
16007
16008   /* Do partial setup of input buffer for the sake of generating
16009      early #line directives (when -g is in effect).  */
16010
16011   fp = &instack[++indepth];
16012   memset ((char *) fp, 0, sizeof (FILE_BUF));
16013   if (name == NULL)
16014     name = "";
16015   fp->nominal_fname = fp->fname = name;
16016 }
16017
16018 /* Initialize syntactic classifications of characters.  */
16019
16020 static void
16021 ffecom_initialize_char_syntax_ ()
16022 {
16023   register int i;
16024
16025   /*
16026    * Set up is_idchar and is_idstart tables.  These should be
16027    * faster than saying (is_alpha (c) || c == '_'), etc.
16028    * Set up these things before calling any routines tthat
16029    * refer to them.
16030    */
16031   for (i = 'a'; i <= 'z'; i++) {
16032     is_idchar[i - 'a' + 'A'] = 1;
16033     is_idchar[i] = 1;
16034     is_idstart[i - 'a' + 'A'] = 1;
16035     is_idstart[i] = 1;
16036   }
16037   for (i = '0'; i <= '9'; i++)
16038     is_idchar[i] = 1;
16039   is_idchar['_'] = 1;
16040   is_idstart['_'] = 1;
16041
16042   /* horizontal space table */
16043   is_hor_space[' '] = 1;
16044   is_hor_space['\t'] = 1;
16045   is_hor_space['\v'] = 1;
16046   is_hor_space['\f'] = 1;
16047   is_hor_space['\r'] = 1;
16048
16049   is_space[' '] = 1;
16050   is_space['\t'] = 1;
16051   is_space['\v'] = 1;
16052   is_space['\f'] = 1;
16053   is_space['\n'] = 1;
16054   is_space['\r'] = 1;
16055 }
16056
16057 static void
16058 ffecom_close_include_ (FILE *f)
16059 {
16060   fclose (f);
16061
16062   indepth--;
16063   input_file_stack_tick++;
16064
16065   ffewhere_line_kill (instack[indepth].line);
16066   ffewhere_column_kill (instack[indepth].column);
16067 }
16068
16069 static int
16070 ffecom_decode_include_option_ (char *spec)
16071 {
16072   struct file_name_list *dirtmp;
16073
16074   if (! ignore_srcdir && !strcmp (spec, "-"))
16075     ignore_srcdir = 1;
16076   else
16077     {
16078       dirtmp = (struct file_name_list *)
16079         xmalloc (sizeof (struct file_name_list));
16080       dirtmp->next = 0;         /* New one goes on the end */
16081       dirtmp->fname = spec;
16082       dirtmp->got_name_map = 0;
16083       if (spec[0] == 0)
16084         error ("Directory name must immediately follow -I");
16085       else
16086         append_include_chain (dirtmp, dirtmp);
16087     }
16088   return 1;
16089 }
16090
16091 /* Open INCLUDEd file.  */
16092
16093 static FILE *
16094 ffecom_open_include_ (char *name, ffewhereLine l, ffewhereColumn c)
16095 {
16096   char *fbeg = name;
16097   size_t flen = strlen (fbeg);
16098   struct file_name_list *search_start = include; /* Chain of dirs to search */
16099   struct file_name_list dsp[1]; /* First in chain, if #include "..." */
16100   struct file_name_list *searchptr = 0;
16101   char *fname;          /* Dynamically allocated fname buffer */
16102   FILE *f;
16103   FILE_BUF *fp;
16104
16105   if (flen == 0)
16106     return NULL;
16107
16108   dsp[0].fname = NULL;
16109
16110   /* If -I- was specified, don't search current dir, only spec'd ones. */
16111   if (!ignore_srcdir)
16112     {
16113       for (fp = &instack[indepth]; fp >= instack; fp--)
16114         {
16115           int n;
16116           char *ep;
16117           const char *nam;
16118
16119           if ((nam = fp->nominal_fname) != NULL)
16120             {
16121               /* Found a named file.  Figure out dir of the file,
16122                  and put it in front of the search list.  */
16123               dsp[0].next = search_start;
16124               search_start = dsp;
16125 #ifndef VMS
16126               ep = strrchr (nam, '/');
16127 #ifdef DIR_SEPARATOR
16128             if (ep == NULL) ep = strrchr (nam, DIR_SEPARATOR);
16129             else {
16130               char *tmp = strrchr (nam, DIR_SEPARATOR);
16131               if (tmp != NULL && tmp > ep) ep = tmp;
16132             }
16133 #endif
16134 #else                           /* VMS */
16135               ep = strrchr (nam, ']');
16136               if (ep == NULL) ep = strrchr (nam, '>');
16137               if (ep == NULL) ep = strrchr (nam, ':');
16138               if (ep != NULL) ep++;
16139 #endif                          /* VMS */
16140               if (ep != NULL)
16141                 {
16142                   n = ep - nam;
16143                   dsp[0].fname = (char *) xmalloc (n + 1);
16144                   strncpy (dsp[0].fname, nam, n);
16145                   dsp[0].fname[n] = '\0';
16146                   if (n + INCLUDE_LEN_FUDGE > max_include_len)
16147                     max_include_len = n + INCLUDE_LEN_FUDGE;
16148                 }
16149               else
16150                 dsp[0].fname = NULL; /* Current directory */
16151               dsp[0].got_name_map = 0;
16152               break;
16153             }
16154         }
16155     }
16156
16157   /* Allocate this permanently, because it gets stored in the definitions
16158      of macros.  */
16159   fname = xmalloc (max_include_len + flen + 4);
16160   /* + 2 above for slash and terminating null.  */
16161   /* + 2 added for '.h' on VMS (to support '#include filename') (NOT USED
16162      for g77 yet).  */
16163
16164   /* If specified file name is absolute, just open it.  */
16165
16166   if (*fbeg == '/'
16167 #ifdef DIR_SEPARATOR
16168       || *fbeg == DIR_SEPARATOR
16169 #endif
16170       )
16171     {
16172       strncpy (fname, (char *) fbeg, flen);
16173       fname[flen] = 0;
16174       f = open_include_file (fname, NULL_PTR);
16175     }
16176   else
16177     {
16178       f = NULL;
16179
16180       /* Search directory path, trying to open the file.
16181          Copy each filename tried into FNAME.  */
16182
16183       for (searchptr = search_start; searchptr; searchptr = searchptr->next)
16184         {
16185           if (searchptr->fname)
16186             {
16187               /* The empty string in a search path is ignored.
16188                  This makes it possible to turn off entirely
16189                  a standard piece of the list.  */
16190               if (searchptr->fname[0] == 0)
16191                 continue;
16192               strcpy (fname, skip_redundant_dir_prefix (searchptr->fname));
16193               if (fname[0] && fname[strlen (fname) - 1] != '/')
16194                 strcat (fname, "/");
16195               fname[strlen (fname) + flen] = 0;
16196             }
16197           else
16198             fname[0] = 0;
16199
16200           strncat (fname, fbeg, flen);
16201 #ifdef VMS
16202           /* Change this 1/2 Unix 1/2 VMS file specification into a
16203              full VMS file specification */
16204           if (searchptr->fname && (searchptr->fname[0] != 0))
16205             {
16206               /* Fix up the filename */
16207               hack_vms_include_specification (fname);
16208             }
16209           else
16210             {
16211               /* This is a normal VMS filespec, so use it unchanged.  */
16212               strncpy (fname, (char *) fbeg, flen);
16213               fname[flen] = 0;
16214 #if 0   /* Not for g77.  */
16215               /* if it's '#include filename', add the missing .h */
16216               if (strchr (fname, '.') == NULL)
16217                 strcat (fname, ".h");
16218 #endif
16219             }
16220 #endif /* VMS */
16221           f = open_include_file (fname, searchptr);
16222 #ifdef EACCES
16223           if (f == NULL && errno == EACCES)
16224             {
16225               print_containing_files (FFEBAD_severityWARNING);
16226               ffebad_start_msg ("At %0, INCLUDE file %A exists, but is not readable",
16227                                 FFEBAD_severityWARNING);
16228               ffebad_string (fname);
16229               ffebad_here (0, l, c);
16230               ffebad_finish ();
16231             }
16232 #endif
16233           if (f != NULL)
16234             break;
16235         }
16236     }
16237
16238   if (f == NULL)
16239     {
16240       /* A file that was not found.  */
16241
16242       strncpy (fname, (char *) fbeg, flen);
16243       fname[flen] = 0;
16244       print_containing_files (ffebad_severity (FFEBAD_OPEN_INCLUDE));
16245       ffebad_start (FFEBAD_OPEN_INCLUDE);
16246       ffebad_here (0, l, c);
16247       ffebad_string (fname);
16248       ffebad_finish ();
16249     }
16250
16251   if (dsp[0].fname != NULL)
16252     free (dsp[0].fname);
16253
16254   if (f == NULL)
16255     return NULL;
16256
16257   if (indepth >= (INPUT_STACK_MAX - 1))
16258     {
16259       print_containing_files (FFEBAD_severityFATAL);
16260       ffebad_start_msg ("At %0, INCLUDE nesting too deep",
16261                         FFEBAD_severityFATAL);
16262       ffebad_string (fname);
16263       ffebad_here (0, l, c);
16264       ffebad_finish ();
16265       return NULL;
16266     }
16267
16268   instack[indepth].line = ffewhere_line_use (l);
16269   instack[indepth].column = ffewhere_column_use (c);
16270
16271   fp = &instack[indepth + 1];
16272   memset ((char *) fp, 0, sizeof (FILE_BUF));
16273   fp->nominal_fname = fp->fname = fname;
16274   fp->dir = searchptr;
16275
16276   indepth++;
16277   input_file_stack_tick++;
16278
16279   return f;
16280 }
16281 #endif  /* FFECOM_GCC_INCLUDE */
16282
16283 /**INDENT* (Do not reformat this comment even with -fca option.)
16284    Data-gathering files: Given the source file listed below, compiled with
16285    f2c I obtained the output file listed after that, and from the output
16286    file I derived the above code.
16287
16288 -------- (begin input file to f2c)
16289         implicit none
16290         character*10 A1,A2
16291         complex C1,C2
16292         integer I1,I2
16293         real R1,R2
16294         double precision D1,D2
16295 C
16296         call getem(A1,A2,C1,C2,I1,I2,R1,R2,D1,D2)
16297 c /
16298         call fooI(I1/I2)
16299         call fooR(R1/I1)
16300         call fooD(D1/I1)
16301         call fooC(C1/I1)
16302         call fooR(R1/R2)
16303         call fooD(R1/D1)
16304         call fooD(D1/D2)
16305         call fooD(D1/R1)
16306         call fooC(C1/C2)
16307         call fooC(C1/R1)
16308         call fooZ(C1/D1)
16309 c **
16310         call fooI(I1**I2)
16311         call fooR(R1**I1)
16312         call fooD(D1**I1)
16313         call fooC(C1**I1)
16314         call fooR(R1**R2)
16315         call fooD(R1**D1)
16316         call fooD(D1**D2)
16317         call fooD(D1**R1)
16318         call fooC(C1**C2)
16319         call fooC(C1**R1)
16320         call fooZ(C1**D1)
16321 c FFEINTRIN_impABS
16322         call fooR(ABS(R1))
16323 c FFEINTRIN_impACOS
16324         call fooR(ACOS(R1))
16325 c FFEINTRIN_impAIMAG
16326         call fooR(AIMAG(C1))
16327 c FFEINTRIN_impAINT
16328         call fooR(AINT(R1))
16329 c FFEINTRIN_impALOG
16330         call fooR(ALOG(R1))
16331 c FFEINTRIN_impALOG10
16332         call fooR(ALOG10(R1))
16333 c FFEINTRIN_impAMAX0
16334         call fooR(AMAX0(I1,I2))
16335 c FFEINTRIN_impAMAX1
16336         call fooR(AMAX1(R1,R2))
16337 c FFEINTRIN_impAMIN0
16338         call fooR(AMIN0(I1,I2))
16339 c FFEINTRIN_impAMIN1
16340         call fooR(AMIN1(R1,R2))
16341 c FFEINTRIN_impAMOD
16342         call fooR(AMOD(R1,R2))
16343 c FFEINTRIN_impANINT
16344         call fooR(ANINT(R1))
16345 c FFEINTRIN_impASIN
16346         call fooR(ASIN(R1))
16347 c FFEINTRIN_impATAN
16348         call fooR(ATAN(R1))
16349 c FFEINTRIN_impATAN2
16350         call fooR(ATAN2(R1,R2))
16351 c FFEINTRIN_impCABS
16352         call fooR(CABS(C1))
16353 c FFEINTRIN_impCCOS
16354         call fooC(CCOS(C1))
16355 c FFEINTRIN_impCEXP
16356         call fooC(CEXP(C1))
16357 c FFEINTRIN_impCHAR
16358         call fooA(CHAR(I1))
16359 c FFEINTRIN_impCLOG
16360         call fooC(CLOG(C1))
16361 c FFEINTRIN_impCONJG
16362         call fooC(CONJG(C1))
16363 c FFEINTRIN_impCOS
16364         call fooR(COS(R1))
16365 c FFEINTRIN_impCOSH
16366         call fooR(COSH(R1))
16367 c FFEINTRIN_impCSIN
16368         call fooC(CSIN(C1))
16369 c FFEINTRIN_impCSQRT
16370         call fooC(CSQRT(C1))
16371 c FFEINTRIN_impDABS
16372         call fooD(DABS(D1))
16373 c FFEINTRIN_impDACOS
16374         call fooD(DACOS(D1))
16375 c FFEINTRIN_impDASIN
16376         call fooD(DASIN(D1))
16377 c FFEINTRIN_impDATAN
16378         call fooD(DATAN(D1))
16379 c FFEINTRIN_impDATAN2
16380         call fooD(DATAN2(D1,D2))
16381 c FFEINTRIN_impDCOS
16382         call fooD(DCOS(D1))
16383 c FFEINTRIN_impDCOSH
16384         call fooD(DCOSH(D1))
16385 c FFEINTRIN_impDDIM
16386         call fooD(DDIM(D1,D2))
16387 c FFEINTRIN_impDEXP
16388         call fooD(DEXP(D1))
16389 c FFEINTRIN_impDIM
16390         call fooR(DIM(R1,R2))
16391 c FFEINTRIN_impDINT
16392         call fooD(DINT(D1))
16393 c FFEINTRIN_impDLOG
16394         call fooD(DLOG(D1))
16395 c FFEINTRIN_impDLOG10
16396         call fooD(DLOG10(D1))
16397 c FFEINTRIN_impDMAX1
16398         call fooD(DMAX1(D1,D2))
16399 c FFEINTRIN_impDMIN1
16400         call fooD(DMIN1(D1,D2))
16401 c FFEINTRIN_impDMOD
16402         call fooD(DMOD(D1,D2))
16403 c FFEINTRIN_impDNINT
16404         call fooD(DNINT(D1))
16405 c FFEINTRIN_impDPROD
16406         call fooD(DPROD(R1,R2))
16407 c FFEINTRIN_impDSIGN
16408         call fooD(DSIGN(D1,D2))
16409 c FFEINTRIN_impDSIN
16410         call fooD(DSIN(D1))
16411 c FFEINTRIN_impDSINH
16412         call fooD(DSINH(D1))
16413 c FFEINTRIN_impDSQRT
16414         call fooD(DSQRT(D1))
16415 c FFEINTRIN_impDTAN
16416         call fooD(DTAN(D1))
16417 c FFEINTRIN_impDTANH
16418         call fooD(DTANH(D1))
16419 c FFEINTRIN_impEXP
16420         call fooR(EXP(R1))
16421 c FFEINTRIN_impIABS
16422         call fooI(IABS(I1))
16423 c FFEINTRIN_impICHAR
16424         call fooI(ICHAR(A1))
16425 c FFEINTRIN_impIDIM
16426         call fooI(IDIM(I1,I2))
16427 c FFEINTRIN_impIDNINT
16428         call fooI(IDNINT(D1))
16429 c FFEINTRIN_impINDEX
16430         call fooI(INDEX(A1,A2))
16431 c FFEINTRIN_impISIGN
16432         call fooI(ISIGN(I1,I2))
16433 c FFEINTRIN_impLEN
16434         call fooI(LEN(A1))
16435 c FFEINTRIN_impLGE
16436         call fooL(LGE(A1,A2))
16437 c FFEINTRIN_impLGT
16438         call fooL(LGT(A1,A2))
16439 c FFEINTRIN_impLLE
16440         call fooL(LLE(A1,A2))
16441 c FFEINTRIN_impLLT
16442         call fooL(LLT(A1,A2))
16443 c FFEINTRIN_impMAX0
16444         call fooI(MAX0(I1,I2))
16445 c FFEINTRIN_impMAX1
16446         call fooI(MAX1(R1,R2))
16447 c FFEINTRIN_impMIN0
16448         call fooI(MIN0(I1,I2))
16449 c FFEINTRIN_impMIN1
16450         call fooI(MIN1(R1,R2))
16451 c FFEINTRIN_impMOD
16452         call fooI(MOD(I1,I2))
16453 c FFEINTRIN_impNINT
16454         call fooI(NINT(R1))
16455 c FFEINTRIN_impSIGN
16456         call fooR(SIGN(R1,R2))
16457 c FFEINTRIN_impSIN
16458         call fooR(SIN(R1))
16459 c FFEINTRIN_impSINH
16460         call fooR(SINH(R1))
16461 c FFEINTRIN_impSQRT
16462         call fooR(SQRT(R1))
16463 c FFEINTRIN_impTAN
16464         call fooR(TAN(R1))
16465 c FFEINTRIN_impTANH
16466         call fooR(TANH(R1))
16467 c FFEINTRIN_imp_CMPLX_C
16468         call fooC(cmplx(C1,C2))
16469 c FFEINTRIN_imp_CMPLX_D
16470         call fooZ(cmplx(D1,D2))
16471 c FFEINTRIN_imp_CMPLX_I
16472         call fooC(cmplx(I1,I2))
16473 c FFEINTRIN_imp_CMPLX_R
16474         call fooC(cmplx(R1,R2))
16475 c FFEINTRIN_imp_DBLE_C
16476         call fooD(dble(C1))
16477 c FFEINTRIN_imp_DBLE_D
16478         call fooD(dble(D1))
16479 c FFEINTRIN_imp_DBLE_I
16480         call fooD(dble(I1))
16481 c FFEINTRIN_imp_DBLE_R
16482         call fooD(dble(R1))
16483 c FFEINTRIN_imp_INT_C
16484         call fooI(int(C1))
16485 c FFEINTRIN_imp_INT_D
16486         call fooI(int(D1))
16487 c FFEINTRIN_imp_INT_I
16488         call fooI(int(I1))
16489 c FFEINTRIN_imp_INT_R
16490         call fooI(int(R1))
16491 c FFEINTRIN_imp_REAL_C
16492         call fooR(real(C1))
16493 c FFEINTRIN_imp_REAL_D
16494         call fooR(real(D1))
16495 c FFEINTRIN_imp_REAL_I
16496         call fooR(real(I1))
16497 c FFEINTRIN_imp_REAL_R
16498         call fooR(real(R1))
16499 c
16500 c FFEINTRIN_imp_INT_D:
16501 c
16502 c FFEINTRIN_specIDINT
16503         call fooI(IDINT(D1))
16504 c
16505 c FFEINTRIN_imp_INT_R:
16506 c
16507 c FFEINTRIN_specIFIX
16508         call fooI(IFIX(R1))
16509 c FFEINTRIN_specINT
16510         call fooI(INT(R1))
16511 c
16512 c FFEINTRIN_imp_REAL_D:
16513 c
16514 c FFEINTRIN_specSNGL
16515         call fooR(SNGL(D1))
16516 c
16517 c FFEINTRIN_imp_REAL_I:
16518 c
16519 c FFEINTRIN_specFLOAT
16520         call fooR(FLOAT(I1))
16521 c FFEINTRIN_specREAL
16522         call fooR(REAL(I1))
16523 c
16524         end
16525 -------- (end input file to f2c)
16526
16527 -------- (begin output from providing above input file as input to:
16528 --------  `f2c | gcc -E -C - | sed -e "s:/[*]*://:g" -e "s:[*]*[/]://:g" \
16529 --------     -e "s:^#.*$::g"')
16530
16531 //  -- translated by f2c (version 19950223).
16532    You must link the resulting object file with the libraries:
16533         -lf2c -lm   (in that order)
16534 //
16535
16536
16537 // f2c.h  --  Standard Fortran to C header file //
16538
16539 ///  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
16540
16541         - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) //
16542
16543
16544
16545
16546 // F2C_INTEGER will normally be `int' but would be `long' on 16-bit systems //
16547 // we assume short, float are OK //
16548 typedef long int // long int // integer;
16549 typedef char *address;
16550 typedef short int shortint;
16551 typedef float real;
16552 typedef double doublereal;
16553 typedef struct { real r, i; } complex;
16554 typedef struct { doublereal r, i; } doublecomplex;
16555 typedef long int // long int // logical;
16556 typedef short int shortlogical;
16557 typedef char logical1;
16558 typedef char integer1;
16559 // typedef long long longint; // // system-dependent //
16560
16561
16562
16563
16564 // Extern is for use with -E //
16565
16566
16567
16568
16569 // I/O stuff //
16570
16571
16572
16573
16574
16575
16576
16577
16578 typedef long int // int or long int // flag;
16579 typedef long int // int or long int // ftnlen;
16580 typedef long int // int or long int // ftnint;
16581
16582
16583 //external read, write//
16584 typedef struct
16585 {       flag cierr;
16586         ftnint ciunit;
16587         flag ciend;
16588         char *cifmt;
16589         ftnint cirec;
16590 } cilist;
16591
16592 //internal read, write//
16593 typedef struct
16594 {       flag icierr;
16595         char *iciunit;
16596         flag iciend;
16597         char *icifmt;
16598         ftnint icirlen;
16599         ftnint icirnum;
16600 } icilist;
16601
16602 //open//
16603 typedef struct
16604 {       flag oerr;
16605         ftnint ounit;
16606         char *ofnm;
16607         ftnlen ofnmlen;
16608         char *osta;
16609         char *oacc;
16610         char *ofm;
16611         ftnint orl;
16612         char *oblnk;
16613 } olist;
16614
16615 //close//
16616 typedef struct
16617 {       flag cerr;
16618         ftnint cunit;
16619         char *csta;
16620 } cllist;
16621
16622 //rewind, backspace, endfile//
16623 typedef struct
16624 {       flag aerr;
16625         ftnint aunit;
16626 } alist;
16627
16628 // inquire //
16629 typedef struct
16630 {       flag inerr;
16631         ftnint inunit;
16632         char *infile;
16633         ftnlen infilen;
16634         ftnint  *inex;  //parameters in standard's order//
16635         ftnint  *inopen;
16636         ftnint  *innum;
16637         ftnint  *innamed;
16638         char    *inname;
16639         ftnlen  innamlen;
16640         char    *inacc;
16641         ftnlen  inacclen;
16642         char    *inseq;
16643         ftnlen  inseqlen;
16644         char    *indir;
16645         ftnlen  indirlen;
16646         char    *infmt;
16647         ftnlen  infmtlen;
16648         char    *inform;
16649         ftnint  informlen;
16650         char    *inunf;
16651         ftnlen  inunflen;
16652         ftnint  *inrecl;
16653         ftnint  *innrec;
16654         char    *inblank;
16655         ftnlen  inblanklen;
16656 } inlist;
16657
16658
16659
16660 union Multitype {       // for multiple entry points //
16661         integer1 g;
16662         shortint h;
16663         integer i;
16664         // longint j; //
16665         real r;
16666         doublereal d;
16667         complex c;
16668         doublecomplex z;
16669         };
16670
16671 typedef union Multitype Multitype;
16672
16673 typedef long Long;      // No longer used; formerly in Namelist //
16674
16675 struct Vardesc {        // for Namelist //
16676         char *name;
16677         char *addr;
16678         ftnlen *dims;
16679         int  type;
16680         };
16681 typedef struct Vardesc Vardesc;
16682
16683 struct Namelist {
16684         char *name;
16685         Vardesc **vars;
16686         int nvars;
16687         };
16688 typedef struct Namelist Namelist;
16689
16690
16691
16692
16693
16694
16695
16696
16697 // procedure parameter types for -A and -C++ //
16698
16699
16700
16701
16702 typedef int // Unknown procedure type // (*U_fp)();
16703 typedef shortint (*J_fp)();
16704 typedef integer (*I_fp)();
16705 typedef real (*R_fp)();
16706 typedef doublereal (*D_fp)(), (*E_fp)();
16707 typedef // Complex // void  (*C_fp)();
16708 typedef // Double Complex // void  (*Z_fp)();
16709 typedef logical (*L_fp)();
16710 typedef shortlogical (*K_fp)();
16711 typedef // Character // void  (*H_fp)();
16712 typedef // Subroutine // int (*S_fp)();
16713
16714 // E_fp is for real functions when -R is not specified //
16715 typedef void  C_f;      // complex function //
16716 typedef void  H_f;      // character function //
16717 typedef void  Z_f;      // double complex function //
16718 typedef doublereal E_f; // real function with -R not specified //
16719
16720 // undef any lower-case symbols that your C compiler predefines, e.g.: //
16721
16722
16723 // (No such symbols should be defined in a strict ANSI C compiler.
16724    We can avoid trouble with f2c-translated code by using
16725    gcc -ansi [-traditional].) //
16726
16727
16728
16729
16730
16731
16732
16733
16734
16735
16736
16737
16738
16739
16740
16741
16742
16743
16744
16745
16746
16747
16748
16749 // Main program // MAIN__()
16750 {
16751     // System generated locals //
16752     integer i__1;
16753     real r__1, r__2;
16754     doublereal d__1, d__2;
16755     complex q__1;
16756     doublecomplex z__1, z__2, z__3;
16757     logical L__1;
16758     char ch__1[1];
16759
16760     // Builtin functions //
16761     void c_div();
16762     integer pow_ii();
16763     double pow_ri(), pow_di();
16764     void pow_ci();
16765     double pow_dd();
16766     void pow_zz();
16767     double acos(), r_imag(), r_int(), log(), r_lg10(), r_mod(), r_nint(),
16768             asin(), atan(), atan2(), c_abs();
16769     void c_cos(), c_exp(), c_log(), r_cnjg();
16770     double cos(), cosh();
16771     void c_sin(), c_sqrt();
16772     double d_dim(), exp(), r_dim(), d_int(), d_lg10(), d_mod(), d_nint(),
16773             d_sign(), sin(), sinh(), sqrt(), tan(), tanh();
16774     integer i_dim(), i_dnnt(), i_indx(), i_sign(), i_len();
16775     logical l_ge(), l_gt(), l_le(), l_lt();
16776     integer i_nint();
16777     double r_sign();
16778
16779     // Local variables //
16780     extern // Subroutine // int fooa_(), fooc_(), food_(), fooi_(), foor_(),
16781             fool_(), fooz_(), getem_();
16782     static char a1[10], a2[10];
16783     static complex c1, c2;
16784     static doublereal d1, d2;
16785     static integer i1, i2;
16786     static real r1, r2;
16787
16788
16789     getem_(a1, a2, &c1, &c2, &i1, &i2, &r1, &r2, &d1, &d2, 10L, 10L);
16790 // / //
16791     i__1 = i1 / i2;
16792     fooi_(&i__1);
16793     r__1 = r1 / i1;
16794     foor_(&r__1);
16795     d__1 = d1 / i1;
16796     food_(&d__1);
16797     d__1 = (doublereal) i1;
16798     q__1.r = c1.r / d__1, q__1.i = c1.i / d__1;
16799     fooc_(&q__1);
16800     r__1 = r1 / r2;
16801     foor_(&r__1);
16802     d__1 = r1 / d1;
16803     food_(&d__1);
16804     d__1 = d1 / d2;
16805     food_(&d__1);
16806     d__1 = d1 / r1;
16807     food_(&d__1);
16808     c_div(&q__1, &c1, &c2);
16809     fooc_(&q__1);
16810     q__1.r = c1.r / r1, q__1.i = c1.i / r1;
16811     fooc_(&q__1);
16812     z__1.r = c1.r / d1, z__1.i = c1.i / d1;
16813     fooz_(&z__1);
16814 // ** //
16815     i__1 = pow_ii(&i1, &i2);
16816     fooi_(&i__1);
16817     r__1 = pow_ri(&r1, &i1);
16818     foor_(&r__1);
16819     d__1 = pow_di(&d1, &i1);
16820     food_(&d__1);
16821     pow_ci(&q__1, &c1, &i1);
16822     fooc_(&q__1);
16823     d__1 = (doublereal) r1;
16824     d__2 = (doublereal) r2;
16825     r__1 = pow_dd(&d__1, &d__2);
16826     foor_(&r__1);
16827     d__2 = (doublereal) r1;
16828     d__1 = pow_dd(&d__2, &d1);
16829     food_(&d__1);
16830     d__1 = pow_dd(&d1, &d2);
16831     food_(&d__1);
16832     d__2 = (doublereal) r1;
16833     d__1 = pow_dd(&d1, &d__2);
16834     food_(&d__1);
16835     z__2.r = c1.r, z__2.i = c1.i;
16836     z__3.r = c2.r, z__3.i = c2.i;
16837     pow_zz(&z__1, &z__2, &z__3);
16838     q__1.r = z__1.r, q__1.i = z__1.i;
16839     fooc_(&q__1);
16840     z__2.r = c1.r, z__2.i = c1.i;
16841     z__3.r = r1, z__3.i = 0.;
16842     pow_zz(&z__1, &z__2, &z__3);
16843     q__1.r = z__1.r, q__1.i = z__1.i;
16844     fooc_(&q__1);
16845     z__2.r = c1.r, z__2.i = c1.i;
16846     z__3.r = d1, z__3.i = 0.;
16847     pow_zz(&z__1, &z__2, &z__3);
16848     fooz_(&z__1);
16849 // FFEINTRIN_impABS //
16850     r__1 = (doublereal)((  r1  ) >= 0 ? (  r1  ) : -(  r1  ))  ;
16851     foor_(&r__1);
16852 // FFEINTRIN_impACOS //
16853     r__1 = acos(r1);
16854     foor_(&r__1);
16855 // FFEINTRIN_impAIMAG //
16856     r__1 = r_imag(&c1);
16857     foor_(&r__1);
16858 // FFEINTRIN_impAINT //
16859     r__1 = r_int(&r1);
16860     foor_(&r__1);
16861 // FFEINTRIN_impALOG //
16862     r__1 = log(r1);
16863     foor_(&r__1);
16864 // FFEINTRIN_impALOG10 //
16865     r__1 = r_lg10(&r1);
16866     foor_(&r__1);
16867 // FFEINTRIN_impAMAX0 //
16868     r__1 = (real) (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
16869     foor_(&r__1);
16870 // FFEINTRIN_impAMAX1 //
16871     r__1 = (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16872     foor_(&r__1);
16873 // FFEINTRIN_impAMIN0 //
16874     r__1 = (real) (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
16875     foor_(&r__1);
16876 // FFEINTRIN_impAMIN1 //
16877     r__1 = (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
16878     foor_(&r__1);
16879 // FFEINTRIN_impAMOD //
16880     r__1 = r_mod(&r1, &r2);
16881     foor_(&r__1);
16882 // FFEINTRIN_impANINT //
16883     r__1 = r_nint(&r1);
16884     foor_(&r__1);
16885 // FFEINTRIN_impASIN //
16886     r__1 = asin(r1);
16887     foor_(&r__1);
16888 // FFEINTRIN_impATAN //
16889     r__1 = atan(r1);
16890     foor_(&r__1);
16891 // FFEINTRIN_impATAN2 //
16892     r__1 = atan2(r1, r2);
16893     foor_(&r__1);
16894 // FFEINTRIN_impCABS //
16895     r__1 = c_abs(&c1);
16896     foor_(&r__1);
16897 // FFEINTRIN_impCCOS //
16898     c_cos(&q__1, &c1);
16899     fooc_(&q__1);
16900 // FFEINTRIN_impCEXP //
16901     c_exp(&q__1, &c1);
16902     fooc_(&q__1);
16903 // FFEINTRIN_impCHAR //
16904     *(unsigned char *)&ch__1[0] = i1;
16905     fooa_(ch__1, 1L);
16906 // FFEINTRIN_impCLOG //
16907     c_log(&q__1, &c1);
16908     fooc_(&q__1);
16909 // FFEINTRIN_impCONJG //
16910     r_cnjg(&q__1, &c1);
16911     fooc_(&q__1);
16912 // FFEINTRIN_impCOS //
16913     r__1 = cos(r1);
16914     foor_(&r__1);
16915 // FFEINTRIN_impCOSH //
16916     r__1 = cosh(r1);
16917     foor_(&r__1);
16918 // FFEINTRIN_impCSIN //
16919     c_sin(&q__1, &c1);
16920     fooc_(&q__1);
16921 // FFEINTRIN_impCSQRT //
16922     c_sqrt(&q__1, &c1);
16923     fooc_(&q__1);
16924 // FFEINTRIN_impDABS //
16925     d__1 = (( d1 ) >= 0 ? ( d1 ) : -( d1 )) ;
16926     food_(&d__1);
16927 // FFEINTRIN_impDACOS //
16928     d__1 = acos(d1);
16929     food_(&d__1);
16930 // FFEINTRIN_impDASIN //
16931     d__1 = asin(d1);
16932     food_(&d__1);
16933 // FFEINTRIN_impDATAN //
16934     d__1 = atan(d1);
16935     food_(&d__1);
16936 // FFEINTRIN_impDATAN2 //
16937     d__1 = atan2(d1, d2);
16938     food_(&d__1);
16939 // FFEINTRIN_impDCOS //
16940     d__1 = cos(d1);
16941     food_(&d__1);
16942 // FFEINTRIN_impDCOSH //
16943     d__1 = cosh(d1);
16944     food_(&d__1);
16945 // FFEINTRIN_impDDIM //
16946     d__1 = d_dim(&d1, &d2);
16947     food_(&d__1);
16948 // FFEINTRIN_impDEXP //
16949     d__1 = exp(d1);
16950     food_(&d__1);
16951 // FFEINTRIN_impDIM //
16952     r__1 = r_dim(&r1, &r2);
16953     foor_(&r__1);
16954 // FFEINTRIN_impDINT //
16955     d__1 = d_int(&d1);
16956     food_(&d__1);
16957 // FFEINTRIN_impDLOG //
16958     d__1 = log(d1);
16959     food_(&d__1);
16960 // FFEINTRIN_impDLOG10 //
16961     d__1 = d_lg10(&d1);
16962     food_(&d__1);
16963 // FFEINTRIN_impDMAX1 //
16964     d__1 = (( d1 ) >= ( d2 ) ? ( d1 ) : ( d2 )) ;
16965     food_(&d__1);
16966 // FFEINTRIN_impDMIN1 //
16967     d__1 = (( d1 ) <= ( d2 ) ? ( d1 ) : ( d2 )) ;
16968     food_(&d__1);
16969 // FFEINTRIN_impDMOD //
16970     d__1 = d_mod(&d1, &d2);
16971     food_(&d__1);
16972 // FFEINTRIN_impDNINT //
16973     d__1 = d_nint(&d1);
16974     food_(&d__1);
16975 // FFEINTRIN_impDPROD //
16976     d__1 = (doublereal) r1 * r2;
16977     food_(&d__1);
16978 // FFEINTRIN_impDSIGN //
16979     d__1 = d_sign(&d1, &d2);
16980     food_(&d__1);
16981 // FFEINTRIN_impDSIN //
16982     d__1 = sin(d1);
16983     food_(&d__1);
16984 // FFEINTRIN_impDSINH //
16985     d__1 = sinh(d1);
16986     food_(&d__1);
16987 // FFEINTRIN_impDSQRT //
16988     d__1 = sqrt(d1);
16989     food_(&d__1);
16990 // FFEINTRIN_impDTAN //
16991     d__1 = tan(d1);
16992     food_(&d__1);
16993 // FFEINTRIN_impDTANH //
16994     d__1 = tanh(d1);
16995     food_(&d__1);
16996 // FFEINTRIN_impEXP //
16997     r__1 = exp(r1);
16998     foor_(&r__1);
16999 // FFEINTRIN_impIABS //
17000     i__1 = (( i1 ) >= 0 ? ( i1 ) : -( i1 )) ;
17001     fooi_(&i__1);
17002 // FFEINTRIN_impICHAR //
17003     i__1 = *(unsigned char *)a1;
17004     fooi_(&i__1);
17005 // FFEINTRIN_impIDIM //
17006     i__1 = i_dim(&i1, &i2);
17007     fooi_(&i__1);
17008 // FFEINTRIN_impIDNINT //
17009     i__1 = i_dnnt(&d1);
17010     fooi_(&i__1);
17011 // FFEINTRIN_impINDEX //
17012     i__1 = i_indx(a1, a2, 10L, 10L);
17013     fooi_(&i__1);
17014 // FFEINTRIN_impISIGN //
17015     i__1 = i_sign(&i1, &i2);
17016     fooi_(&i__1);
17017 // FFEINTRIN_impLEN //
17018     i__1 = i_len(a1, 10L);
17019     fooi_(&i__1);
17020 // FFEINTRIN_impLGE //
17021     L__1 = l_ge(a1, a2, 10L, 10L);
17022     fool_(&L__1);
17023 // FFEINTRIN_impLGT //
17024     L__1 = l_gt(a1, a2, 10L, 10L);
17025     fool_(&L__1);
17026 // FFEINTRIN_impLLE //
17027     L__1 = l_le(a1, a2, 10L, 10L);
17028     fool_(&L__1);
17029 // FFEINTRIN_impLLT //
17030     L__1 = l_lt(a1, a2, 10L, 10L);
17031     fool_(&L__1);
17032 // FFEINTRIN_impMAX0 //
17033     i__1 = (( i1 ) >= ( i2 ) ? ( i1 ) : ( i2 )) ;
17034     fooi_(&i__1);
17035 // FFEINTRIN_impMAX1 //
17036     i__1 = (integer) (doublereal)((  r1  ) >= (  r2  ) ? (  r1  ) : (  r2  ))  ;
17037     fooi_(&i__1);
17038 // FFEINTRIN_impMIN0 //
17039     i__1 = (( i1 ) <= ( i2 ) ? ( i1 ) : ( i2 )) ;
17040     fooi_(&i__1);
17041 // FFEINTRIN_impMIN1 //
17042     i__1 = (integer) (doublereal)((  r1  ) <= (  r2  ) ? (  r1  ) : (  r2  ))  ;
17043     fooi_(&i__1);
17044 // FFEINTRIN_impMOD //
17045     i__1 = i1 % i2;
17046     fooi_(&i__1);
17047 // FFEINTRIN_impNINT //
17048     i__1 = i_nint(&r1);
17049     fooi_(&i__1);
17050 // FFEINTRIN_impSIGN //
17051     r__1 = r_sign(&r1, &r2);
17052     foor_(&r__1);
17053 // FFEINTRIN_impSIN //
17054     r__1 = sin(r1);
17055     foor_(&r__1);
17056 // FFEINTRIN_impSINH //
17057     r__1 = sinh(r1);
17058     foor_(&r__1);
17059 // FFEINTRIN_impSQRT //
17060     r__1 = sqrt(r1);
17061     foor_(&r__1);
17062 // FFEINTRIN_impTAN //
17063     r__1 = tan(r1);
17064     foor_(&r__1);
17065 // FFEINTRIN_impTANH //
17066     r__1 = tanh(r1);
17067     foor_(&r__1);
17068 // FFEINTRIN_imp_CMPLX_C //
17069     r__1 = c1.r;
17070     r__2 = c2.r;
17071     q__1.r = r__1, q__1.i = r__2;
17072     fooc_(&q__1);
17073 // FFEINTRIN_imp_CMPLX_D //
17074     z__1.r = d1, z__1.i = d2;
17075     fooz_(&z__1);
17076 // FFEINTRIN_imp_CMPLX_I //
17077     r__1 = (real) i1;
17078     r__2 = (real) i2;
17079     q__1.r = r__1, q__1.i = r__2;
17080     fooc_(&q__1);
17081 // FFEINTRIN_imp_CMPLX_R //
17082     q__1.r = r1, q__1.i = r2;
17083     fooc_(&q__1);
17084 // FFEINTRIN_imp_DBLE_C //
17085     d__1 = (doublereal) c1.r;
17086     food_(&d__1);
17087 // FFEINTRIN_imp_DBLE_D //
17088     d__1 = d1;
17089     food_(&d__1);
17090 // FFEINTRIN_imp_DBLE_I //
17091     d__1 = (doublereal) i1;
17092     food_(&d__1);
17093 // FFEINTRIN_imp_DBLE_R //
17094     d__1 = (doublereal) r1;
17095     food_(&d__1);
17096 // FFEINTRIN_imp_INT_C //
17097     i__1 = (integer) c1.r;
17098     fooi_(&i__1);
17099 // FFEINTRIN_imp_INT_D //
17100     i__1 = (integer) d1;
17101     fooi_(&i__1);
17102 // FFEINTRIN_imp_INT_I //
17103     i__1 = i1;
17104     fooi_(&i__1);
17105 // FFEINTRIN_imp_INT_R //
17106     i__1 = (integer) r1;
17107     fooi_(&i__1);
17108 // FFEINTRIN_imp_REAL_C //
17109     r__1 = c1.r;
17110     foor_(&r__1);
17111 // FFEINTRIN_imp_REAL_D //
17112     r__1 = (real) d1;
17113     foor_(&r__1);
17114 // FFEINTRIN_imp_REAL_I //
17115     r__1 = (real) i1;
17116     foor_(&r__1);
17117 // FFEINTRIN_imp_REAL_R //
17118     r__1 = r1;
17119     foor_(&r__1);
17120
17121 // FFEINTRIN_imp_INT_D: //
17122
17123 // FFEINTRIN_specIDINT //
17124     i__1 = (integer) d1;
17125     fooi_(&i__1);
17126
17127 // FFEINTRIN_imp_INT_R: //
17128
17129 // FFEINTRIN_specIFIX //
17130     i__1 = (integer) r1;
17131     fooi_(&i__1);
17132 // FFEINTRIN_specINT //
17133     i__1 = (integer) r1;
17134     fooi_(&i__1);
17135
17136 // FFEINTRIN_imp_REAL_D: //
17137
17138 // FFEINTRIN_specSNGL //
17139     r__1 = (real) d1;
17140     foor_(&r__1);
17141
17142 // FFEINTRIN_imp_REAL_I: //
17143
17144 // FFEINTRIN_specFLOAT //
17145     r__1 = (real) i1;
17146     foor_(&r__1);
17147 // FFEINTRIN_specREAL //
17148     r__1 = (real) i1;
17149     foor_(&r__1);
17150
17151 } // MAIN__ //
17152
17153 -------- (end output file from f2c)
17154
17155 */